diff options
| author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
|---|---|---|
| committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
| commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
| tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/testsuite/ada/acats/tests/c4 | |
| download | cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.bz2 cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.xz | |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.
downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.
if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c4')
341 files changed, 55593 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c4/c410001.a b/gcc/testsuite/ada/acats/tests/c4/c410001.a new file mode 100644 index 000000000..26555531b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c410001.a @@ -0,0 +1,303 @@ +-- C410001.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 evaluating an access to subprogram variable containing +-- the value null causes the exception Constraint_Error. +-- Check that the default value for objects of access to subprogram +-- types is null. +-- +-- TEST DESCRIPTION: +-- This test defines a few simple access_to_subprogram types, and +-- objects of those types. It checks that the default values for +-- these objects is null, and that an attempt to make a subprogram +-- call via one of this objects containing a null value causes the +-- predefined exception Constraint_Error. The check is performed +--- both with the default null value, and with an explicitly assigned +-- null value, after the object has been used to successfully designate +-- and call a subprogram. +-- +-- +-- CHANGE HISTORY: +-- 05 APR 96 SAIC Initial version +-- 04 NOV 96 SAIC Revised for 2.1 release +-- 26 FEB 97 PWB.CTA Initialized variable before passing to function +--! + +----------------------------------------------------------------- C410001_0 + +package C410001_0 is + + -- used to "switch state" in the software + Expect_Exception : Boolean; + + -- define a minimal mixture of access_to_subprogram types + + type Proc_Ref is access procedure; + + type Func_Ref is access function(I:Integer) return Integer; + + type Proc_Para_Ref is access procedure(P:Proc_Ref); + + type Func_Para_Ref is access function(F:Func_Ref) return Integer; + + type Prot_Proc_Ref is access protected procedure; + + type Prot_Func_Ref is access protected function return Boolean; + + -- define some subprograms for them to reference + + procedure Proc; + + function Func(I:Integer) return Integer; + + procedure Proc_Para( Param : Proc_Ref ); + + function Func_Para( Param : Func_Ref ) return Integer; + + protected Prot_Obj is + procedure Prot_Proc; + function Prot_Func return Boolean; + end Prot_Obj; + +end C410001_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body C410001_0 is + + -- Note that some failing cases will cause duplicate failure messages; + -- rather than have the procedure/function bodies be null, the error + -- checking code makes for a reasonable anti-optimization feature. + + procedure Proc is + begin + if Expect_Exception then + Report.Failed("Expected exception did not occur: Proc"); + end if; + end Proc; + + function Func(I:Integer) return Integer is + begin + if Expect_Exception then + Report.Failed("Expected exception did not occur: Func"); + end if; + return Report.Ident_Int(I); + end Func; + + procedure Proc_Para( Param : Proc_Ref ) is + begin + + Param.all; -- call by explicit dereference + + if Expect_Exception then + Report.Failed("Expected exception did not occur: Proc_Para"); + end if; + + exception + when Constraint_Error => + if not Expect_Exception then + Report.Failed("Unexpected Constraint_Error: Proc_Para"); + end if; -- else null; expected the exception + when others => Report.Failed("Unexpected exception: Proc_Para"); + end Proc_Para; + + function Func_Para( Param : Func_Ref ) return Integer is + begin + + return Param(1); -- call by implicit dereference + + if Expect_Exception then + Report.Failed("Expected exception did not occur: Func_Para"); + end if; + return 1; -- really just to avoid warnings + + exception + when Constraint_Error => + if not Expect_Exception then + Report.Failed("Unexpected Constraint_Error: Func_Para"); + return 0; + else + return 1995; -- any value other than this is unexpected + end if; + when others => Report.Failed("Unexpected exception: Func_Para"); + return -42; + end Func_Para; + + protected body Prot_Obj is + + procedure Prot_Proc is + begin + if Expect_Exception then + Report.Failed("Expected exception did not occur: Prot_Proc"); + end if; + end Prot_Proc; + + function Prot_Func return Boolean is + begin + if Expect_Exception then + Report.Failed("Expected exception did not occur: Prot_Func"); + end if; + return Report.Ident_Bool( True ); + end Prot_Func; + + end Prot_Obj; + +end C410001_0; + +------------------------------------------------------------------- C410001 + +with Report; +with TCTouch; +with C410001_0; +procedure C410001 is + + Proc_Ref_Var : C410001_0.Proc_Ref; + + Func_Ref_Var : C410001_0.Func_Ref; + + Proc_Para_Ref_Var : C410001_0.Proc_Para_Ref; + + Func_Para_Ref_Var : C410001_0.Func_Para_Ref; + + type Enclosure is record + Prot_Proc_Ref_Var : C410001_0.Prot_Proc_Ref; + Prot_Func_Ref_Var : C410001_0.Prot_Func_Ref; + end record; + + Enclosed : Enclosure; + + Valid_Proc : C410001_0.Proc_Ref := C410001_0.Proc'Access; + + Valid_Func : C410001_0.Func_Ref := C410001_0.Func'Access; + + procedure Make_Calls( Expecting_Exceptions : Boolean ) is + type Case_Numbers is range 1..6; + Some_Integer : Integer := 0; + begin + for Cases in Case_Numbers loop + Catch_Exception : begin + case Cases is + when 1 => Proc_Ref_Var.all; + when 2 => Some_Integer := Func_Ref_Var.all( Some_Integer ); + when 3 => Proc_Para_Ref_Var( Valid_Proc ); + when 4 => Some_Integer := Func_Para_Ref_Var( Valid_Func ); + when 5 => Enclosed.Prot_Proc_Ref_Var.all; + when 6 => TCTouch.Assert( Enclosed.Prot_Func_Ref_Var.all + /= Expecting_Exceptions, + "Case 6"); + end case; + if Expecting_Exceptions then + Report.Failed("Exception expected: Case" + & Case_Numbers'Image(Cases) ); + end if; + exception + when Constraint_Error => + if not Expecting_Exceptions then + Report.Failed("Constraint_Error not expected: Case" + & Case_Numbers'Image(Cases) ); + end if; + when others => + Report.Failed("Wrong/Bad Exception: Case" + & Case_Numbers'Image(Cases) ); + end Catch_Exception; + end loop; + end Make_Calls; + +begin -- Main test procedure. + + Report.Test ("C410001", "Check that evaluating an access to subprogram " & + "variable containing the value null causes the " & + "exception Constraint_Error. Check that the " & + "default value for objects of access to " & + "subprogram types is null" ); + + -- check that the default values are null + declare + use C410001_0; -- make all "="'s visible for all types + begin + TCTouch.Assert( Proc_Ref_Var = null, "Proc_Ref_Var = null" ); + + TCTouch.Assert( Func_Ref_Var = null, "Func_Ref_Var = null" ); + + TCTouch.Assert( Proc_Para_Ref_Var = null, "Proc_Para_Ref_Var = null" ); + + TCTouch.Assert( Func_Para_Ref_Var = null, "Func_Para_Ref_Var = null" ); + + TCTouch.Assert( Enclosed.Prot_Proc_Ref_Var = null, + "Enclosed.Prot_Proc_Ref_Var = null" ); + + TCTouch.Assert( Enclosed.Prot_Func_Ref_Var = null, + "Enclosed.Prot_Func_Ref_Var = null" ); + end; + + -- check that calls via the default values cause Constraint_Error + + C410001_0.Expect_Exception := True; + + Make_Calls( Expecting_Exceptions => True ); + + -- assign non-null values to the objects + + Proc_Ref_Var := C410001_0.Proc'Access; + Func_Ref_Var := C410001_0.Func'Access; + Proc_Para_Ref_Var := C410001_0.Proc_Para'Access; + Func_Para_Ref_Var := C410001_0.Func_Para'Access; + Enclosed := (C410001_0.Prot_Obj.Prot_Proc'Access, + C410001_0.Prot_Obj.Prot_Func'Access); + + -- check that the calls perform normally + + C410001_0.Expect_Exception := False; + + Make_Calls( Expecting_Exceptions => False ); + + -- check that a passed null value causes Constraint_Error + + C410001_0.Expect_Exception := True; + + Proc_Para_Ref_Var( null ); + + TCTouch.Assert( Func_Para_Ref_Var( null ) = 1995, + "Func_Para_Ref_Var( null )"); + + -- assign the null value to the objects + + Proc_Ref_Var := null; + Func_Ref_Var := null; + Proc_Para_Ref_Var := null; + Func_Para_Ref_Var := null; + Enclosed := (null,null); + + -- check that calls now again cause Constraint_Error + + C410001_0.Expect_Exception := True; + + Make_Calls( Expecting_Exceptions => True ); + + Report.Result; + +end C410001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41101d.ada b/gcc/testsuite/ada/acats/tests/c4/c41101d.ada new file mode 100644 index 000000000..c826a227b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41101d.ada @@ -0,0 +1,102 @@ +-- C41101D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR INDEXED COMPONENTS OF THE FORM F(...), CHECK THAT +-- THE NUMBER OF INDEX VALUES, THE TYPE OF THE INDEX +-- VALUES, AND THE REQUIRED TYPE OF THE INDEXED COMPONENT +-- ARE USED TO RESOLVE AN OVERLOADING OF F. + +-- WKB 8/12/81 +-- JBG 10/12/81 +-- SPS 11/1/82 + +WITH REPORT; +PROCEDURE C41101D IS + + USE REPORT; + + TYPE T1 IS ARRAY (1..10) OF INTEGER; + TYPE T2 IS ARRAY (1..10, 1..10) OF INTEGER; + I : INTEGER; + + TYPE U1 IS (MON,TUE,WED,THU,FRI); + TYPE U2 IS ARRAY (U1 RANGE MON..THU) OF INTEGER; + + TYPE V1 IS ARRAY (1..10) OF BOOLEAN; + B : BOOLEAN; + + FUNCTION F RETURN T1 IS + BEGIN + RETURN (1..10 => 1); + END F; + + FUNCTION F RETURN T2 IS + BEGIN + RETURN (1..10 => (1..10 => 2)); + END F; + + FUNCTION G RETURN U2 IS + BEGIN + RETURN (MON..THU => 3); + END G; + + FUNCTION G RETURN T1 IS + BEGIN + RETURN (1..10 => 4); + END G; + + FUNCTION H RETURN T1 IS + BEGIN + RETURN (1..10 => 5); + END H; + + FUNCTION H RETURN V1 IS + BEGIN + RETURN (1..10 => FALSE); + END H; + +BEGIN + + TEST ("C41101D", "WHEN INDEXING FUNCTION RESULTS, INDEX TYPE, " & + "NUMBER OF INDICES, AND COMPONENT TYPE ARE " & + "USED FOR OVERLOADING RESOLUTION"); + + I := F(7); -- NUMBER OF INDEX VALUES. + IF I /= IDENT_INT(1) THEN + FAILED ("WRONG VALUE - 1"); + END IF; + + I := G(3); -- INDEX TYPE. + IF I /= IDENT_INT(4) THEN + FAILED ("WRONG VALUE - 2"); + END IF; + + B := H(5); -- COMPONENT TYPE. + IF B /= IDENT_BOOL(FALSE) THEN + FAILED ("WRONG VALUE - 3"); + END IF; + + RESULT; + +END C41101D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41103a.ada b/gcc/testsuite/ada/acats/tests/c4/c41103a.ada new file mode 100644 index 000000000..21feafb36 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41103a.ada @@ -0,0 +1,239 @@ +-- C41103A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NAME IN AN INDEXED_COMPONENT MAY BE: +-- AN IDENTIFIER DENOTING AN ARRAY OBJECT - N1; +-- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE +-- DESIGNATES AN ARRAY OBJECT - N2; +-- A FUNCTION CALL DELIVERING AN ARRAY OBJECT USING +-- A PREDEFINED FUNCTION - &, +-- A USER-DEFINED FUNCTION - F1; +-- A FUNCTION CALL DELIVERING AN ACCESS VALUE THAT +-- DESIGNATES AN ARRAY - F2; +-- A SLICE (CHECKING UPPER AND LOWER BOUND COMPONENTS) - N3; +-- AN INDEXED COMPONENT DENOTING AN ARRAY OBJECT +-- (ARRAY OF ARRAYS) - N4; +-- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT +-- ENCLOSING ITS DECLARATION - C41103A.N1; +-- A RECORD COMPONENT (OF A RECORD CONTAINING ONE OR MORE +-- ARRAYS WHOSE BOUNDS DEPEND ON A DISCRIMINANT) - N5. +-- CHECK THAT THE APPROPRIATE COMPONENT IS ACCESSED (FOR +-- STATIC INDICES). + +-- WKB 7/27/81 +-- JRK 7/28/81 +-- SPS 10/26/82 +-- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + +WITH REPORT; +USE REPORT; +PROCEDURE C41103A IS + + TYPE A1 IS ARRAY (INTEGER RANGE 1..4) OF INTEGER; + N1 : A1 := (1,2,3,4); + +BEGIN + TEST ("C41103A", "CHECK THAT AN INDEXED_COMPONENT MAY BE OF " & + "CERTAIN FORMS AND THAT THE APPROPRIATE " & + "COMPONENT IS ACCESSED (FOR STATIC INDICES)"); + + DECLARE + + TYPE A2 IS ARRAY (INTEGER RANGE 1..4) OF BOOLEAN; + TYPE A3 IS ACCESS A1; + TYPE A4 IS ARRAY (INTEGER RANGE 1..4) OF A1; + TYPE R (LENGTH : INTEGER) IS + RECORD + S : STRING (1..LENGTH); + END RECORD; + + N2 : A3 := NEW A1' (1,2,3,4); + N3 : ARRAY (1..7) OF INTEGER := (1,2,3,4,5,6,7); + N4 : A4 := (1 => (1,2,3,4), 2 => (5,6,7,8), + 3 => (9,10,11,12), 4 => (13,14,15,16)); + N5 : R(4) := (LENGTH => 4, S => "ABCD"); + + FUNCTION F1 RETURN A2 IS + BEGIN + RETURN (FALSE,FALSE,TRUE,FALSE); + END F1; + + FUNCTION F2 RETURN A3 IS + BEGIN + RETURN N2; + END F2; + + PROCEDURE P1 (X : IN INTEGER; Y : IN OUT INTEGER; + Z : OUT INTEGER; W : IN STRING) IS + BEGIN + IF X /= 2 THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - " & W); + END IF; + IF Y /= 3 THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W); + END IF; + Y := 8; + Z := 9; + END P1; + + PROCEDURE P2 (X : CHARACTER) IS + BEGIN + IF X /= 'C' THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - '&'"); + END IF; + END P2; + + PROCEDURE P3 (X : BOOLEAN) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - F1"); + END IF; + END P3; + + PROCEDURE P5 (X : IN CHARACTER; Y : IN OUT CHARACTER; + Z : OUT CHARACTER) IS + BEGIN + IF X /= 'A' THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - N5"); + END IF; + IF Y /= 'D' THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - N5"); + END IF; + Y := 'Y'; + Z := 'Z'; + END P5; + + BEGIN + + IF N1(2) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N1"); + END IF; + N1(2) := 7; + IF N1 /= (1,7,3,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N1"); + END IF; + N1 := (1,2,3,4); + P1 (N1(2), N1(3), N1(1), "N1"); + IF N1 /= (9,2,8,4) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N1"); + END IF; + + IF N2(3) /= 3 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N2"); + END IF; + N2(3) := 7; + IF N2.ALL /= (1,2,7,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N2"); + END IF; + N2.ALL := (2,1,4,3); + P1 (N2(1), N2(4), N2(2), "N2"); + IF N2.ALL /= (2,9,4,8) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N2"); + END IF; + + IF "&" (STRING'("AB"), STRING'("CDEF"))(5) /= CHARACTER'('E') THEN + FAILED ("WRONG VALUE FOR EXPRESSION - '&'"); + END IF; + P2 ("&" ("AB", "CD")(3)); + + IF F1(3) /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F1"); + END IF; + P3 (F1(3)); + + N2 := NEW A1' (1,2,3,4); + IF F2(2) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F2"); + END IF; + F2(3) := 7; + IF N2.ALL /= (1,2,7,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - F2"); + END IF; + N2.ALL := (1,2,3,4); + P1 (F2(2), F2(3), F2(1), "F2"); + IF N2.ALL /= (9,2,8,4) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2"); + END IF; + + IF N3(2..5)(5) /= 5 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N3"); + END IF; + N3(2..5)(2) := 8; + IF N3 /= (1,8,3,4,5,6,7) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N3"); + END IF; + N3 := (5,3,4,2,1,6,7); + P1 (N3(2..5)(4), N3(2..5)(2), N3(2..5)(5), "N3"); + IF N3 /= (5,8,4,2,9,6,7) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N3"); + END IF; + + IF N4(1)(2) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N4"); + END IF; + N4(3)(1) := 20; + IF N4 /= ((1,2,3,4),(5,6,7,8),(20,10,11,12), + (13,14,15,16)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N4"); + END IF; + N4 := (1 => (0,6,4,2), 2 => (10,11,12,13), + 3 => (14,15,16,17), 4 => (7,5,3,1)); + P1 (N4(1)(4), N4(4)(3), N4(2)(1), "N4"); + IF N4 /= ((0,6,4,2),(9,11,12,13),(14,15,16,17), + (7,5,8,1)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N4"); + END IF; + + N1 := (1,2,3,4); + IF C41103A.N1(2) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - C41103A.N1"); + END IF; + C41103A.N1(2) := 7; + IF N1 /= (1,7,3,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - C41103A.N1"); + END IF; + N1 := (1,2,3,4); + P1 (C41103A.N1(2), C41103A.N1(3), C41103A.N1(1), + "C41103A.N1"); + IF N1 /= (9,2,8,4) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER " & + "- C41103A.N1"); + END IF; + + IF N5.S(3) /= 'C' THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N5"); + END IF; + N5.S(4) := 'X'; + IF N5.S /= "ABCX" THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N5"); + END IF; + N5.S := "ABCD"; + P5 (N5.S(1), N5.S(4), N5.S(2)); + IF N5.S /= "AZCY" THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N5"); + END IF; + END; + + RESULT; +END C41103A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41103b.ada b/gcc/testsuite/ada/acats/tests/c4/c41103b.ada new file mode 100644 index 000000000..7fbab7174 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41103b.ada @@ -0,0 +1,366 @@ +-- C41103B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE NAME IN AN INDEXED_COMPONENT MAY BE: +-- AN IDENTIFIER DENOTING AN ARRAY OBJECT - N1; +-- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE +-- DESIGNATES AN ARRAY OBJECT - N2; +-- A FUNCTION CALL DELIVERING AN ARRAY OBJECT USING +-- PREDEFINED FUNCTIONS - &, AND THE LOGICAL OPERATORS +-- A USER-DEFINED FUNCTION - F1; +-- A FUNCTION CALL DELIVERING AN ACCESS VALUE THAT +-- DESIGNATES AN ARRAY - F2; +-- A SLICE (CHECKING UPPER AND LOWER BOUND COMPONENTS) - N3; +-- AN INDEXED COMPONENT DENOTING AN ARRAY OBJECT +-- (ARRAY OF ARRAYS) - N4; +-- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT +-- ENCLOSING ITS DECLARATION - C41103B.N1; +-- A RECORD COMPONENT (OF A RECORD CONTAINING ONE OR MORE +-- ARRAYS WHOSE BOUNDS DEPEND ON A DISCRIMINANT) - N5. +-- CHECK THAT THE APPROPRIATE COMPONENT IS ACCESSED (FOR +-- DYNAMIC INDICES). + +-- HISTORY: +-- WKB 08/05/81 CREATED ORIGINAL TEST. +-- SPS 10/26/82 +-- BCB 08/02/88 MODIFIED HEADER FORMAT AND ADDED CALLS TO THE +-- LOGICAL OPERATORS. +-- BCB 04/16/90 MODIFIED SLICE TEST TO INCLUDE A READING OF THE +-- COMPONENT DESIGNATED BY THE LOWER BOUND OF THE +-- SLICE. ADDED TEST FOR PREFIX OF INDEXED COMPONENT +-- HAVING A LIMITED TYPE. +-- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + +WITH REPORT; +USE REPORT; +PROCEDURE C41103B IS + + TYPE A1 IS ARRAY (INTEGER RANGE 1..4) OF INTEGER; + N1 : A1 := (1,2,3,4); + +BEGIN + TEST ("C41103B", "CHECK THAT AN INDEXED_COMPONENT MAY BE OF " & + "CERTAIN FORMS AND THAT THE APPROPRIATE " & + "COMPONENT IS ACCESSED (FOR DYNAMIC INDICES)"); + + DECLARE + + TYPE A2 IS ARRAY (INTEGER RANGE 1..4) OF BOOLEAN; + TYPE A3 IS ACCESS A1; + TYPE A4 IS ARRAY (INTEGER RANGE 1..4) OF A1; + TYPE R (LENGTH : INTEGER) IS + RECORD + S : STRING (1..LENGTH); + END RECORD; + + N2 : A3 := NEW A1' (1,2,3,4); + N3 : ARRAY (1..7) OF INTEGER := (1,2,3,4,5,6,7); + N4 : A4 := (1 => (1,2,3,4), 2 => (5,6,7,8), + 3 => (9,10,11,12), 4 => (13,14,15,16)); + N5 : R(4) := (LENGTH => 4, S => "ABCD"); + + M2A : A2 := (TRUE,FALSE,TRUE,FALSE); + M2B : A2 := (TRUE,TRUE,FALSE,FALSE); + + FUNCTION F1 RETURN A2 IS + BEGIN + RETURN (FALSE,FALSE,TRUE,FALSE); + END F1; + + FUNCTION F2 RETURN A3 IS + BEGIN + RETURN N2; + END F2; + + PROCEDURE P1 (X : IN INTEGER; Y : IN OUT INTEGER; + Z : OUT INTEGER; W : IN STRING) IS + BEGIN + IF X /= 2 THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - " & W); + END IF; + IF Y /= 3 THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W); + END IF; + Y := 8; + Z := 9; + END P1; + + PROCEDURE P2 (X : CHARACTER) IS + BEGIN + IF X /= 'C' THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - '&'"); + END IF; + END P2; + + PROCEDURE P3 (X : BOOLEAN) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - F1"); + END IF; + END P3; + + PROCEDURE P5 (X : IN CHARACTER; Y : IN OUT CHARACTER; + Z : OUT CHARACTER) IS + BEGIN + IF X /= 'A' THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - N5"); + END IF; + IF Y /= 'D' THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - N5"); + END IF; + Y := 'Y'; + Z := 'Z'; + END P5; + + PROCEDURE P6 (X : BOOLEAN) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - NOT"); + END IF; + END P6; + + PROCEDURE P7 (X : BOOLEAN) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - AND"); + END IF; + END P7; + + PROCEDURE P8 (X : BOOLEAN) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - OR"); + END IF; + END P8; + + PROCEDURE P9 (X : BOOLEAN) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - XOR"); + END IF; + END P9; + + BEGIN + + IF N1(IDENT_INT(2)) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N1"); + END IF; + N1(IDENT_INT(2)) := 7; + IF N1 /= (1,7,3,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N1"); + END IF; + N1 := (1,2,3,4); + P1 (N1(IDENT_INT(2)), N1(IDENT_INT(3)), + N1(IDENT_INT(1)), "N1"); + IF N1 /= (9,2,8,4) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N1"); + END IF; + + IF N2(IDENT_INT(3)) /= 3 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N2"); + END IF; + N2(IDENT_INT(3)) := 7; + IF N2.ALL /= (1,2,7,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N2"); + END IF; + N2.ALL := (2,1,4,3); + P1 (N2(IDENT_INT(1)), N2(IDENT_INT(4)), + N2(IDENT_INT(2)), "N2"); + IF N2.ALL /= (2,9,4,8) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N2"); + END IF; + + IF "&" (STRING'("AB"), STRING'("CDEF"))(IDENT_INT(5)) + /= CHARACTER'('E') THEN + FAILED ("WRONG VALUE FOR EXPRESSION - '&'"); + END IF; + P2 ("&" ("AB", "CD")(IDENT_INT(3))); + + IF "NOT" (M2A)(IDENT_INT(4)) /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'NOT'"); + END IF; + P6 ("NOT" (M2A)(IDENT_INT(4))); + + IF "AND" (M2A,M2B)(IDENT_INT(3)) /= FALSE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'AND'"); + END IF; + P7 ("AND" (M2A,M2B)(IDENT_INT(1))); + + IF "OR" (M2A,M2B)(IDENT_INT(3)) /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'OR'"); + END IF; + P8 ("OR" (M2A,M2B)(IDENT_INT(3))); + + IF "XOR" (M2A,M2B)(IDENT_INT(1)) /= FALSE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'XOR'"); + END IF; + P9 ("XOR" (M2A,M2B)(IDENT_INT(3))); + + IF F1(IDENT_INT(3)) /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F1"); + END IF; + P3 (F1(IDENT_INT(3))); + + N2 := NEW A1'(1,2,3,4); + IF F2(IDENT_INT(2)) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F2"); + END IF; + F2(IDENT_INT(3)) := 7; + IF N2.ALL /= (1,2,7,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - F2"); + END IF; + N2.ALL := (1,2,3,4); + P1 (F2(IDENT_INT(2)), F2(IDENT_INT(3)), + F2(IDENT_INT(1)), "F2"); + IF N2.ALL /= (9,2,8,4) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2"); + END IF; + + IF N3(2..5)(IDENT_INT(2)) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION (LOWER BOUND) - N3"); + END IF; + IF N3(2..5)(IDENT_INT(5)) /= 5 THEN + FAILED ("WRONG VALUE FOR EXPRESSION (UPPER BOUND) - N3"); + END IF; + N3(2..5)(IDENT_INT(2)) := 8; + IF N3 /= (1,8,3,4,5,6,7) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N3"); + END IF; + N3 := (5,3,4,2,1,6,7); + P1 (N3(2..5)(IDENT_INT(4)), N3(2..5)(IDENT_INT(2)), + N3(2..5)(IDENT_INT(5)), "N3"); + IF N3 /= (5,8,4,2,9,6,7) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N3"); + END IF; + + IF N4(1)(IDENT_INT(2)) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N4"); + END IF; + N4(3)(IDENT_INT(1)) := 20; + IF N4 /= ((1,2,3,4),(5,6,7,8),(20,10,11,12), + (13,14,15,16)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N4"); + END IF; + N4 := (1 => (0,6,4,2), 2 => (10,11,12,13), + 3 => (14,15,16,17), 4 => (7,5,3,1)); + P1 (N4(1)(IDENT_INT(4)), N4(4)(IDENT_INT(3)), + N4(2)(IDENT_INT(1)), "N4"); + IF N4 /= ((0,6,4,2),(9,11,12,13),(14,15,16,17), + (7,5,8,1)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N4"); + END IF; + + N1 := (1,2,3,4); + IF C41103B.N1(IDENT_INT(2)) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - C41103B.N1"); + END IF; + C41103B.N1(IDENT_INT(2)) := 7; + IF N1 /= (1,7,3,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - C41103B.N1"); + END IF; + N1 := (1,2,3,4); + P1 (C41103B.N1(IDENT_INT(2)), C41103B.N1(IDENT_INT(3)), + C41103B.N1(IDENT_INT(1)), "C41103B.N1"); + IF N1 /= (9,2,8,4) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER " & + "- C41103B.N1"); + END IF; + + IF N5.S(IDENT_INT(3)) /= 'C' THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N5"); + END IF; + N5.S(IDENT_INT(4)) := 'X'; + IF N5.S /= "ABCX" THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N5"); + END IF; + N5.S := "ABCD"; + P5 (N5.S(IDENT_INT(1)), N5.S(IDENT_INT(4)), + N5.S(IDENT_INT(2))); + IF N5.S /= "AZCY" THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N5"); + END IF; + + DECLARE + PACKAGE P IS + TYPE LIM IS LIMITED PRIVATE; + PROCEDURE INIT (V : OUT LIM; X,Y,Z : INTEGER); + PROCEDURE ASSIGN (ONE : OUT LIM; TWO : LIM); + FUNCTION "=" (ONE,TWO : LIM) RETURN BOOLEAN; + PRIVATE + TYPE LIM IS ARRAY(1..3) OF INTEGER; + END P; + + USE P; + + TYPE A IS ARRAY(1..3) OF LIM; + + H : A; + + N6 : LIM; + + PACKAGE BODY P IS + PROCEDURE INIT (V : OUT LIM; X,Y,Z : INTEGER) IS + BEGIN + V := (X,Y,Z); + END INIT; + + PROCEDURE ASSIGN (ONE : OUT LIM; TWO : LIM) IS + BEGIN + ONE := TWO; + END ASSIGN; + + FUNCTION "=" (ONE,TWO : LIM) RETURN BOOLEAN IS + BEGIN + IF ONE(1) = TWO(1) AND ONE(2) = TWO(2) AND + ONE(3) = TWO(3) THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; + END "="; + END P; + + FUNCTION FR RETURN A IS + BEGIN + RETURN H; + END FR; + + BEGIN + INIT (H(1),1,2,3); + INIT (H(2),4,5,6); + INIT (H(3),7,8,9); + INIT (N6,0,0,0); + + ASSIGN (N6,FR(2)); + + IF N6 /= FR(2) THEN + FAILED ("WRONG VALUE FROM LIMITED COMPONENT TYPE"); + END IF; + + END; + END; + + RESULT; +END C41103B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41104a.ada b/gcc/testsuite/ada/acats/tests/c4/c41104a.ada new file mode 100644 index 000000000..540702869 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41104a.ada @@ -0,0 +1,240 @@ +-- C41104A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF AN EXPRESSION GIVES AN INDEX +-- VALUE OUTSIDE THE RANGE SPECIFIED FOR THE INDEX FOR ARRAYS AND ACCESS +-- TYPES. + +-- TBN 9/12/86 +-- EDS 8/03/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C41104A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 5; + SUBTYPE BOOL IS BOOLEAN RANGE TRUE .. TRUE; + SUBTYPE CHAR IS CHARACTER RANGE 'W' .. 'Z'; + TYPE ARRAY1 IS ARRAY (INT RANGE <>) OF INTEGER; + TYPE ARRAY2 IS ARRAY (3 .. 1) OF INTEGER; + TYPE ARRAY3 IS ARRAY (BOOL RANGE <>) OF INTEGER; + TYPE ARRAY4 IS ARRAY (CHAR RANGE <>) OF INTEGER; + + TYPE REC (D : INT) IS + RECORD + A : ARRAY1 (1 .. D); + END RECORD; + + TYPE B_REC (D : BOOL) IS + RECORD + A : ARRAY3 (TRUE .. D); + END RECORD; + + TYPE NULL_REC (D : INT) IS + RECORD + A : ARRAY1 (D .. 1); + END RECORD; + + TYPE NULL_CREC (D : CHAR) IS + RECORD + A : ARRAY4 (D .. 'W'); + END RECORD; + +BEGIN + TEST ("C41104A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF AN " & + "EXPRESSION GIVES AN INDEX VALUE OUTSIDE THE " & + "RANGE SPECIFIED FOR THE INDEX FOR ARRAYS AND " & + "ACCESS TYPES"); + + DECLARE + ARA1 : ARRAY1 (1 .. 5) := (1, 2, 3, 4, 5); + BEGIN + ARA1 (IDENT_INT(0)) := 1; + + BEGIN + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - " & + INTEGER'IMAGE(ARA1 (1))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; +------------------------------------------------------------------------ + DECLARE + TYPE ACC_ARRAY IS ACCESS ARRAY3 (TRUE .. TRUE); + ACC_ARA : ACC_ARRAY := NEW ARRAY3'(TRUE => 2); + BEGIN + ACC_ARA (IDENT_BOOL(FALSE)) := 2; + + BEGIN + + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - " & + INTEGER'IMAGE(ACC_ARA (TRUE))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; +------------------------------------------------------------------------ + DECLARE + ARA2 : ARRAY4 ('Z' .. 'Y'); + BEGIN + ARA2 (IDENT_CHAR('Y')) := 3; + + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 3"); + + BEGIN + COMMENT ("ARA2 (Y) IS " & INTEGER'IMAGE(ARA2 ('Y'))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 3"); + END; +------------------------------------------------------------------------ + DECLARE + TYPE ACC_ARRAY IS ACCESS ARRAY2; + ACC_ARA : ACC_ARRAY := NEW ARRAY2; + BEGIN + ACC_ARA (IDENT_INT(4)) := 4; + + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 4"); + + BEGIN + COMMENT ("ACC_ARA (4) IS " & INTEGER'IMAGE(ACC_ARA (4))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 4"); + END; +------------------------------------------------------------------------ + DECLARE + REC1 : B_REC (TRUE) := (TRUE, A => (TRUE => 5)); + BEGIN + REC1.A (IDENT_BOOL (FALSE)) := 1; + + BEGIN + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - " & + INTEGER'IMAGE(REC1.A (TRUE))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 5"); + END; +------------------------------------------------------------------------ + DECLARE + TYPE ACC_REC IS ACCESS REC (3); + ACC_REC1 : ACC_REC := NEW REC'(3, (4, 5, 6)); + BEGIN + ACC_REC1.A (IDENT_INT(4)) := 4; + + BEGIN + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - " & + INTEGER'IMAGE(ACC_REC1.A (3))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 6"); + END; +------------------------------------------------------------------------ + DECLARE + REC1 : NULL_REC (2); + BEGIN + REC1.A (IDENT_INT(2)) := 1; + + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 7"); + + BEGIN + COMMENT ("REC1.A (2) IS " & INTEGER'IMAGE(REC1.A (2))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 7"); + END; +------------------------------------------------------------------------ + DECLARE + TYPE ACC_REC IS ACCESS NULL_CREC ('Z'); + ACC_REC1 : ACC_REC := NEW NULL_CREC ('Z'); + BEGIN + ACC_REC1.A (IDENT_CHAR('A')) := 4; + + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 8"); + BEGIN + COMMENT ("ACC_REC1.A (A) IS " & + INTEGER'IMAGE(ACC_REC1.A ('A'))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 8"); + END; +------------------------------------------------------------------------ + + RESULT; +END C41104A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41105a.ada b/gcc/testsuite/ada/acats/tests/c4/c41105a.ada new file mode 100644 index 000000000..1b5ad40f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41105a.ada @@ -0,0 +1,104 @@ +-- C41105A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE NAME PART OF AN +-- INDEXED COMPONENT DENOTES AN ACCESS OBJECT WHOSE VALUE IS NULL, +-- AND ALSO IF THE NAME IS A FUNCTION CALL DELIVERING NULL. + +-- HISTORY: +-- WKB 07/29/81 CREATED ORIGINAL TEST. +-- SPS 10/26/82 +-- JET 01/05/88 UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT +-- OPTIMIZATION. + +WITH REPORT; +USE REPORT; +PROCEDURE C41105A IS + +BEGIN + TEST ("C41105A", "CONSTRAINT_ERROR FROM NAMES DENOTING A NULL " & + "ACCESS OBJECT AND A FUNCTION CALL DELIVERING " & + "NULL"); + + DECLARE + + TYPE T1 IS ARRAY (1..2) OF INTEGER; + TYPE A1 IS ACCESS T1; + B : A1 := NEW T1' (1,2); + I : INTEGER; + + BEGIN + + IF EQUAL (3,3) THEN + B := NULL; + END IF; + + I := B(1); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1"); + + IF EQUAL (I,I) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 1"); + + END; + + + DECLARE + + TYPE T2 IS ARRAY (1..2) OF INTEGER; + TYPE A2 IS ACCESS T2; + I : INTEGER; + + FUNCTION F RETURN A2 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN NULL; + END IF; + RETURN NEW T2' (1,2); + END F; + + BEGIN + + I := F(1); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 2"); + + IF EQUAL (I,I) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 2"); + + END; + + RESULT; +END C41105A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41107a.ada b/gcc/testsuite/ada/acats/tests/c4/c41107a.ada new file mode 100644 index 000000000..13781fbf4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41107a.ada @@ -0,0 +1,142 @@ +-- C41107A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR AN ARRAY HAVING BOTH POSITIVE AND NEGATIVE +-- INDEX VALUES, THE PROPER COMPONENT IS SELECTED - A. +-- CHECK THAT FOR AN ARRAY INDEXED WITH AN ENUMERATION TYPE, +-- APPROPRIATE COMPONENTS CAN BE SELECTED - B. +-- CHECK THAT SUBSCRIPT EXPRESSIONS CAN BE OF COMPLEXITY GREATER +-- THAN VARIABLE + - CONSTANT - C. +-- CHECK THAT MULTIPLY DIMENSIONED ARRAYS ARE PROPERLY INDEXED - D. + +-- WKB 7/29/81 +-- JBG 8/21/83 + +WITH REPORT; +USE REPORT; +PROCEDURE C41107A IS + + TYPE T1 IS ARRAY (INTEGER RANGE -2..2) OF INTEGER; + A : T1 := (1,2,3,4,5); + + TYPE COLOR IS (RED,ORANGE,YELLOW,GREEN,BLUE); + TYPE T2 IS ARRAY (COLOR RANGE RED..BLUE) OF INTEGER; + B : T2 := (5,4,3,2,1); + + C : STRING (1..7) := "ABCDEFG"; + + TYPE T4 IS ARRAY (1..4,1..3) OF INTEGER; + D : T4 := (1 => (1,2,3), 2 => (4,5,6), 3 => (7,8,9), + 4 => (0,-1,-2)); + + V1 : INTEGER := IDENT_INT (1); + V2 : INTEGER := IDENT_INT (2); + V3 : INTEGER := IDENT_INT (3); + + PROCEDURE P1 (X : IN INTEGER; Y : IN OUT INTEGER; + Z : OUT INTEGER; W : STRING) IS + BEGIN + IF X /= 1 THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - " & W); + END IF; + IF Y /= 4 THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W); + END IF; + Y := 11; + Z := 12; + END P1; + + PROCEDURE P2 (X : IN CHARACTER; Y : IN OUT CHARACTER; + Z : OUT CHARACTER) IS + BEGIN + IF X /= 'D' THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - C"); + END IF; + IF Y /= 'F' THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - C"); + END IF; + Y := 'Y'; + Z := 'Z'; + END P2; + +BEGIN + TEST ("C41107A", "CHECK THAT THE PROPER COMPONENT IS SELECTED " & + "FOR ARRAYS WITH POS AND NEG INDICES, " & + "ENUMERATION INDICES, COMPLEX SUBSCRIPT " & + "EXPRESSIONS, AND MULTIPLE DIMENSIONS"); + + IF A(IDENT_INT(1)) /= 4 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - A"); + END IF; + A(IDENT_INT(-2)) := 10; + IF A /= (10,2,3,4,5) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - A"); + END IF; + A := (2,1,0,3,4); + P1 (A(-1), A(2), A(-2), "A"); + IF A /= (12,1,0,3,11) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - A"); + END IF; + + IF B(GREEN) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - B"); + END IF; + B(YELLOW) := 10; + IF B /= (5,4,10,2,1) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - B"); + END IF; + B := (1,4,2,3,5); + P1 (B(RED), B(ORANGE), B(BLUE), "B"); + IF B /= (1,11,2,3,12) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - B"); + END IF; + + IF C(3..6)(3**2 / 3 * (2-1) - 6 / 3 + 2) /= 'C' THEN + FAILED ("WRONG VALUE FOR EXPRESSION - C"); + END IF; + C(3..6)(V3**2 / V1 * (V3-V2) + IDENT_INT(4) - V3 * V2 - V1) := 'W'; + IF C /= "ABCDEWG" THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - C"); + END IF; + C := "ABCDEFG"; + P2 (C(3..6)(V3+V1), C(3..6)(V3*V2), C(3..6)((V1+V2)*V1)); + IF C /= "ABZDEYG" THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - C"); + END IF; + + IF D(IDENT_INT(1),IDENT_INT(3)) /= 3 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - D"); + END IF; + D(IDENT_INT(4),IDENT_INT(2)) := 10; + IF D /= ((1,2,3),(4,5,6),(7,8,9),(0,10,-2)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - D"); + END IF; + D := (1 => (0,2,3), 2 => (4,5,6), 3 => (7,8,9), 4 => (1,-1,-2)); + P1 (D(4,1), D(2,1), D(3,2), "D"); + IF D /= ((0,2,3),(11,5,6),(7,12,9),(1,-1,-2)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - D"); + END IF; + + RESULT; +END C41107A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41201d.ada b/gcc/testsuite/ada/acats/tests/c4/c41201d.ada new file mode 100644 index 000000000..a589ba765 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41201d.ada @@ -0,0 +1,105 @@ +-- C41201D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR SLICED COMPONENTS OF THE FORM F(...), CHECK THAT +-- THE REQUIREMENT FOR A ONE-DIMENSIONAL ARRAY AND THE +-- TYPE OF THE INDEX ARE USED TO RESOLVE AN OVERLOADING OF F. + +-- WKB 8/11/81 +-- JBG 10/12/81 +-- SPS 11/1/82 + +WITH REPORT; +PROCEDURE C41201D IS + + USE REPORT; + + TYPE T IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + SUBTYPE T1 IS T(1..10); + TYPE T2 IS ARRAY (1..10, 1..10) OF INTEGER; + TT : T(1..3); + + SUBTYPE U1 IS T(1..10); + TYPE U2 IS (MON,TUE,WED,THU,FRI); + SUBTYPE SU2 IS U2 RANGE MON .. THU; + TYPE U3 IS ARRAY (SU2) OF INTEGER; + UU : T(1..3); + + TYPE V IS ARRAY (INTEGER RANGE <> ) OF BOOLEAN; + SUBTYPE V1 IS V(1..10); + SUBTYPE V2 IS T(1..10); + VV : V(2..5); + + FUNCTION F RETURN T1 IS + BEGIN + RETURN (1,1,1,1,5,6,7,8,9,10); + END F; + + FUNCTION F RETURN T2 IS + BEGIN + RETURN (1..10 => (1,2,3,4,5,6,7,8,9,10)); + END F; + + FUNCTION G RETURN U1 IS + BEGIN + RETURN (3,3,3,3,5,6,7,8,9,10); + END G; + + FUNCTION G RETURN U3 IS + BEGIN + RETURN (0,1,2,3); + END G; + + FUNCTION H RETURN V1 IS + BEGIN + RETURN (1|3..10 => FALSE, 2 => IDENT_BOOL(TRUE)); + END H; + + FUNCTION H RETURN V2 IS + BEGIN + RETURN (1..10 => 5); + END H; + +BEGIN + + TEST ("C41201D", "WHEN SLICING FUNCTION RESULTS, TYPE OF " & + "RESULT IS USED FOR OVERLOADING RESOLUTION"); + + IF F(1..3) /= + F(IDENT_INT(2)..IDENT_INT(4)) THEN -- NUMBER OF DIMENSIONS. + FAILED ("WRONG VALUE - 1"); + END IF; + + IF G(1..3) /= + G(IDENT_INT(2)..IDENT_INT(4)) THEN -- INDEX TYPE. + FAILED ("WRONG VALUE - 2"); + END IF; + + IF NOT IDENT_BOOL(H(2..3)(2)) THEN -- COMPONENT TYPE. + FAILED ("WRONG VALUE - 3"); + END IF; + + RESULT; + +END C41201D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41203a.ada b/gcc/testsuite/ada/acats/tests/c4/c41203a.ada new file mode 100644 index 000000000..7e751650f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41203a.ada @@ -0,0 +1,241 @@ +-- C41203A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NAME PART OF A SLICE MAY BE: +-- AN IDENTIFIER DENOTING A ONE DIMENSIONAL ARRAY OBJECT - N1; +-- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE +-- DESIGNATES A ONE DIMENSIONAL ARRAY OBJECT - N2; +-- A FUNCTION CALL DELIVERING A ONE DIMENSIONAL ARRAY OBJECT USING +-- A PREDEFINED FUNCTION - &, +-- A USER-DEFINED FUNCTION - F1; +-- A FUNCTION CALL DELIVERING AN ACCESS VALUE THAT +-- DESIGNATES A ONE DIMENSIONAL ARRAY - F2; +-- A SLICE - N3; +-- AN INDEXED COMPONENT DENOTING A ONE DIMENSIONAL ARRAY OBJECT +-- (ARRAY OF ARRAYS) - N4; +-- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT +-- ENCLOSING ITS DECLARATION - C41203A.N1; +-- A RECORD COMPONENT (OF A RECORD CONTAINING ONE OR MORE +-- ARRAYS WHOSE BOUNDS DEPEND ON A DISCRIMINANT) - N5. +-- CHECK THAT THE APPROPRIATE SLICE IS ACCESSED (FOR +-- STATIC INDICES). + +-- WKB 8/5/81 +-- SPS 11/1/82 +-- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + +WITH REPORT; +USE REPORT; +PROCEDURE C41203A IS + + TYPE T1 IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + SUBTYPE A1 IS T1 (1..6); + N1 : A1 := (1,2,3,4,5,6); + +BEGIN + TEST ("C41203A", "CHECK THAT THE NAME PART OF A SLICE MAY BE " & + "OF CERTAIN FORMS AND THAT THE APPROPRIATE " & + "SLICE IS ACCESSED (FOR STATIC INDICES)"); + + DECLARE + + TYPE T2 IS ARRAY (INTEGER RANGE <> ) OF BOOLEAN; + SUBTYPE A2 IS T2 (1..6); + TYPE A3 IS ACCESS A1; + SUBTYPE SI IS INTEGER RANGE 1 .. 3; + TYPE A4 IS ARRAY (SI) OF A1; + TYPE R (LENGTH : INTEGER) IS + RECORD + S : STRING (1..LENGTH); + END RECORD; + + N2 : A3 := NEW A1' (1,2,3,4,5,6); + N3 : T1 (1..7) := (1,2,3,4,5,6,7); + N4 : A4 := (1 => (1,2,3,4,5,6), 2 => (7,8,9,10,11,12), + 3 => (13,14,15,16,17,18)); + N5 : R(6) := (LENGTH => 6, S => "ABCDEF"); + + FUNCTION F1 RETURN A2 IS + BEGIN + RETURN (FALSE,FALSE,TRUE,FALSE,TRUE,TRUE); + END F1; + + FUNCTION F2 RETURN A3 IS + BEGIN + RETURN N2; + END F2; + + PROCEDURE P1 (X : IN T1; Y : IN OUT T1; + Z : OUT T1; W : IN STRING) IS + BEGIN + IF X /= (1,2) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - " & W); + END IF; + IF Y /= (3,4) THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W); + END IF; + Y := (10,11); + Z := (12,13); + END P1; + + PROCEDURE P2 (X : STRING) IS + BEGIN + IF X /= "BC" THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - '&'"); + END IF; + END P2; + + PROCEDURE P3 (X : T2) IS + BEGIN + IF X /= (FALSE,TRUE,FALSE) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - F1"); + END IF; + END P3; + + PROCEDURE P5 (X : IN STRING; Y : IN OUT STRING; + Z : OUT STRING) IS + BEGIN + IF X /= "EF" THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - N5"); + END IF; + IF Y /= "CD" THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - N5"); + END IF; + Y := "XY"; + Z := "WZ"; + END P5; + + BEGIN + + IF N1(1..2) /= (1,2) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N1"); + END IF; + N1(1..2) := (7,8); + IF N1 /= (7,8,3,4,5,6) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N1"); + END IF; + N1 := (1,2,3,4,5,6); + P1 (N1(1..2), N1(3..4), N1(5..6), "N1"); + IF N1 /= (1,2,10,11,12,13) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N1"); + END IF; + + IF N2(4..6) /= (4,5,6) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N2"); + END IF; + N2(4..6) := (7,8,9); + IF N2.ALL /= (1,2,3,7,8,9) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N2"); + END IF; + N2.ALL := (1,2,5,6,3,4); + P1 (N2(1..2), N2(5..6), N2(3..4), "N2"); + IF N2.ALL /= (1,2,12,13,10,11) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N2"); + END IF; + + IF "&" (STRING'("AB"), STRING'("CDEF"))(4..6) /= STRING'("DEF") THEN + FAILED ("WRONG VALUE FOR EXPRESSION - '&'"); + END IF; + P2 ("&" ("AB", "CD")(2..3)); + + IF F1(1..2) /= (FALSE,FALSE) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F1"); + END IF; + P3 (F1(2..4)); + + N2 := NEW A1' (1,2,3,4,5,6); + IF F2(2..6) /= (2,3,4,5,6) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F2"); + END IF; + F2(3..3) := (5 => 7); + IF N2.ALL /= (1,2,7,4,5,6) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - F2"); + END IF; + N2.ALL := (5,6,1,2,3,4); + P1 (F2(3..4), F2(5..6), F2(1..2), "F2"); + IF N2.ALL /= (12,13,1,2,10,11) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2"); + END IF; + + IF N3(2..7)(2..4) /= (2,3,4) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N3"); + END IF; + N3(2..7)(4..5) := (8,9); + IF N3 /= (1,2,3,8,9,6,7) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N3"); + END IF; + N3 := (5,3,4,1,2,6,7); + P1 (N3(2..7)(4..5), N3(2..7)(2..3), N3(2..7)(6..7), "N3"); + IF N3 /= (5,10,11,1,2,12,13) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N3"); + END IF; + + IF N4(1)(3..5) /= (3,4,5) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N4"); + END IF; + N4(2)(1..3) := (21,22,23); + IF N4 /= ((1,2,3,4,5,6),(21,22,23,10,11,12), + (13,14,15,16,17,18)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N4"); + END IF; + N4 := (1 => (18,19,20,21,22,23), 2 => (17,16,15,1,2,14), + 3 => (7,3,4,5,6,8)); + P1 (N4(2)(4..5), N4(3)(2..3), N4(1)(5..6), "N4"); + IF N4 /= ((18,19,20,21,12,13),(17,16,15,1,2,14), + (7,10,11,5,6,8)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N4"); + END IF; + + N1 := (1,2,3,4,5,6); + IF C41203A.N1(1..2) /= (1,2) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - C41203A.N1"); + END IF; + C41203A.N1(1..2) := (7,8); + IF N1 /= (7,8,3,4,5,6) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - C41203A.N1"); + END IF; + N1 := (1,2,3,4,5,6); + P1 (C41203A.N1(1..2), C41203A.N1(3..4), C41203A.N1(5..6), + "C41203A.N1"); + IF N1 /= (1,2,10,11,12,13) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER " & + "- C41203A.N1"); + END IF; + + IF N5.S(1..5) /= "ABCDE" THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N5"); + END IF; + N5.S(4..6) := "PQR"; + IF N5.S /= "ABCPQR" THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N5"); + END IF; + N5.S := "ABCDEF"; + P5 (N5.S(5..6), N5.S(3..4), N5.S(1..2)); + IF N5.S /= "WZXYEF" THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N5"); + END IF; + END; + + RESULT; +END C41203A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41203b.ada b/gcc/testsuite/ada/acats/tests/c4/c41203b.ada new file mode 100644 index 000000000..2bfb0952e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41203b.ada @@ -0,0 +1,378 @@ +-- C41203B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE NAME PART OF A SLICE MAY BE: +-- AN IDENTIFIER DENOTING A ONE DIMENSIONAL ARRAY OBJECT - N1; +-- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE +-- DESIGNATES A ONE DIMENSIONAL ARRAY OBJECT - N2; +-- A FUNCTION CALL DELIVERING A ONE DIMENSIONAL ARRAY OBJECT +-- USING PREDEFINED FUNCTIONS - &, AND THE LOGICAL OPERATORS +-- A USER-DEFINED FUNCTION - F1; +-- A FUNCTION CALL DELIVERING AN ACCESS VALUE THAT +-- DESIGNATES A ONE DIMENSIONAL ARRAY - F2; +-- A SLICE - N3; +-- AN INDEXED COMPONENT DENOTING A ONE DIMENSIONAL ARRAY OBJECT +-- (ARRAY OF ARRAYS) - N4; +-- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT +-- ENCLOSING ITS DECLARATION - C41203B.N1; +-- A RECORD COMPONENT (OF A RECORD CONTAINING ONE OR MORE +-- ARRAYS WHOSE BOUNDS DEPEND ON A DISCRIMINANT) - N5. +-- CHECK THAT THE APPROPRIATE SLICE IS ACCESSED (FOR +-- DYNAMIC INDICES). + +-- HISTORY: +-- WKB 08/05/81 CREATED ORIGINAL TEST. +-- SPS 02/04/83 +-- BCB 08/02/88 MODIFIED HEADER FORMAT AND ADDED CALLS TO THE +-- LOGICAL OPERATORS. +-- BCB 04/16/90 ADDED TEST FOR PREFIX OF INDEXED COMPONENT HAVING +-- A LIMITED TYPE. +-- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + +WITH REPORT; +USE REPORT; +PROCEDURE C41203B IS + + TYPE T1 IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + SUBTYPE A1 IS T1 (1..6); + N1 : A1 := (1,2,3,4,5,6); + +BEGIN + TEST ("C41203B", "CHECK THAT THE NAME PART OF A SLICE MAY BE " & + "OF CERTAIN FORMS AND THAT THE APPROPRIATE " & + "SLICE IS ACCESSED (FOR DYNAMIC INDICES)"); + + DECLARE + + TYPE T2 IS ARRAY (INTEGER RANGE <> ) OF BOOLEAN; + SUBTYPE A2 IS T2 (1..6); + TYPE A3 IS ACCESS A1; + TYPE A4 IS ARRAY (INTEGER RANGE 1..3 ) OF A1; + TYPE R (LENGTH : INTEGER) IS + RECORD + S : STRING (1..LENGTH); + END RECORD; + + N2 : A3 := NEW A1'(1,2,3,4,5,6); + N3 : T1(1..7) := (1,2,3,4,5,6,7); + N4 : A4 := (1 => (1,2,3,4,5,6), 2 => (7,8,9,10,11,12), + 3 => (13,14,15,16,17,18)); + N5 : R(6) := (LENGTH => 6, S => "ABCDEF"); + + M2A : A2 := (TRUE,TRUE,TRUE,FALSE,FALSE,FALSE); + M2B : A2 := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE); + + FUNCTION F1 RETURN A2 IS + BEGIN + RETURN (FALSE,FALSE,TRUE,FALSE,TRUE,TRUE); + END F1; + + FUNCTION F2 RETURN A3 IS + BEGIN + RETURN N2; + END F2; + + PROCEDURE P1 (X : IN T1; Y : IN OUT T1; + Z : OUT T1; W : IN STRING) IS + BEGIN + IF X /= (1,2) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - " & W); + END IF; + IF Y /= (3,4) THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W); + END IF; + Y := (10,11); + Z := (12,13); + END P1; + + PROCEDURE P2 (X : STRING) IS + BEGIN + IF X /= "BC" THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - '&'"); + END IF; + END P2; + + PROCEDURE P3 (X : T2) IS + BEGIN + IF X /= (FALSE,TRUE,FALSE) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - F1"); + END IF; + END P3; + + PROCEDURE P5 (X : IN STRING; Y : IN OUT STRING; + Z : OUT STRING) IS + BEGIN + IF X /= "EF" THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - N5"); + END IF; + IF Y /= "CD" THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - N5"); + END IF; + Y := "XY"; + Z := "WZ"; + END P5; + + PROCEDURE P6 (X : T2) IS + BEGIN + IF X /= (FALSE,FALSE,TRUE) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - NOT"); + END IF; + END P6; + + PROCEDURE P7 (X : T2) IS + BEGIN + IF X /= (FALSE,TRUE,FALSE) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - AND"); + END IF; + END P7; + + PROCEDURE P8 (X : T2) IS + BEGIN + IF X /= (FALSE,TRUE,FALSE) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - OR"); + END IF; + END P8; + + PROCEDURE P9 (X : T2) IS + BEGIN + IF X /= (FALSE,TRUE,FALSE) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - XOR"); + END IF; + END P9; + + BEGIN + + IF N1(IDENT_INT(1)..IDENT_INT(2)) /= (1,2) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N1"); + END IF; + N1(IDENT_INT(1)..IDENT_INT(2)) := (7,8); + IF N1 /= (7,8,3,4,5,6) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N1"); + END IF; + N1 := (1,2,3,4,5,6); + P1 (N1(IDENT_INT(1)..IDENT_INT(2)), + N1(IDENT_INT(3)..IDENT_INT(4)), + N1(IDENT_INT(5)..IDENT_INT(6)), "N1"); + IF N1 /= (1,2,10,11,12,13) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N1"); + END IF; + + IF N2(IDENT_INT(4)..IDENT_INT(6)) /= (4,5,6) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N2"); + END IF; + N2(IDENT_INT(4)..IDENT_INT(6)) := (7,8,9); + IF N2.ALL /= (1,2,3,7,8,9) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N2"); + END IF; + N2.ALL := (1,2,5,6,3,4); + P1 (N2(IDENT_INT(1)..IDENT_INT(2)), + N2(IDENT_INT(5)..IDENT_INT(6)), + N2(IDENT_INT(3)..IDENT_INT(4)), "N2"); + IF N2.ALL /= (1,2,12,13,10,11) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N2"); + END IF; + + IF "&" (STRING'("AB"),STRING'("CDEF"))(IDENT_INT(4)..IDENT_INT(6)) + /= STRING'("DEF") THEN + FAILED ("WRONG VALUE FOR EXPRESSION - '&'"); + END IF; + P2 ("&" ("AB","CD")(IDENT_INT(2)..IDENT_INT(3))); + + IF "NOT" (M2A)(IDENT_INT(3)..IDENT_INT(5)) /= + (FALSE,TRUE,TRUE) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'NOT'"); + END IF; + P6 ("NOT" (M2A)(IDENT_INT(2)..IDENT_INT(4))); + + IF "AND" (M2A,M2B)(IDENT_INT(3)..IDENT_INT(5)) /= + (TRUE,FALSE,FALSE) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'AND'"); + END IF; + P7 ("AND" (M2A,M2B)(IDENT_INT(2)..IDENT_INT(4))); + + IF "OR" (M2A,M2B)(IDENT_INT(3)..IDENT_INT(5)) /= + (TRUE,FALSE,TRUE) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'OR'"); + END IF; + P8 ("OR" (M2A,M2B)(IDENT_INT(4)..IDENT_INT(6))); + + IF "XOR" (M2A,M2B)(IDENT_INT(3)..IDENT_INT(5)) /= + (FALSE,FALSE,TRUE) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'XOR'"); + END IF; + P9 ("XOR" (M2A,M2B)(IDENT_INT(1)..IDENT_INT(3))); + + IF F1(IDENT_INT(1)..IDENT_INT(2)) /= (FALSE,FALSE) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F1"); + END IF; + P3 (F1(IDENT_INT(2)..IDENT_INT(4))); + + N2 := NEW A1'(1,2,3,4,5,6); + IF F2(IDENT_INT(2)..IDENT_INT(6)) /= (2,3,4,5,6) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F2"); + END IF; + F2(IDENT_INT(3)..IDENT_INT(3)) := (5 => 7); + IF N2.ALL /= (1,2,7,4,5,6) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - F2"); + END IF; + N2.ALL := (5,6,1,2,3,4); + P1 (F2(IDENT_INT(3)..IDENT_INT(4)), + F2(IDENT_INT(5)..IDENT_INT(6)), + F2(IDENT_INT(1)..IDENT_INT(2)), "F2"); + IF N2.ALL /= (12,13,1,2,10,11) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2"); + END IF; + + IF N3(2..7)(IDENT_INT(2)..IDENT_INT(4)) /= (2,3,4) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N3"); + END IF; + N3(2..7)(IDENT_INT(4)..IDENT_INT(5)) := (8,9); + IF N3 /= (1,2,3,8,9,6,7) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N3"); + END IF; + N3 := (5,3,4,1,2,6,7); + P1 (N3(2..7)(IDENT_INT(4)..IDENT_INT(5)), + N3(2..7)(IDENT_INT(2)..IDENT_INT(3)), + N3(2..7)(IDENT_INT(6)..IDENT_INT(7)), "N3"); + IF N3 /= (5,10,11,1,2,12,13) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N3"); + END IF; + + IF N4(1)(IDENT_INT(3)..IDENT_INT(5)) /= (3,4,5) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N4"); + END IF; + N4(2)(IDENT_INT(1)..IDENT_INT(3)) := (21,22,23); + IF N4 /= ((1,2,3,4,5,6),(21,22,23,10,11,12), + (13,14,15,16,17,18)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N4"); + END IF; + N4 := (1 => (18,19,20,21,22,23), 2 => (17,16,15,1,2,14), + 3 => (7,3,4,5,6,8)); + P1 (N4(2)(IDENT_INT(4)..IDENT_INT(5)), + N4(3)(IDENT_INT(2)..IDENT_INT(3)), + N4(1)(IDENT_INT(5)..IDENT_INT(6)), "N4"); + IF N4 /= ((18,19,20,21,12,13),(17,16,15,1,2,14), + (7,10,11,5,6,8)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N4"); + END IF; + + N1 := (1,2,3,4,5,6); + IF C41203B.N1(IDENT_INT(1)..IDENT_INT(2)) /= (1,2) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - C41203B.N1"); + END IF; + C41203B.N1(IDENT_INT(1)..IDENT_INT(2)) := (7,8); + IF N1 /= (7,8,3,4,5,6) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - C41203B.N1"); + END IF; + N1 := (1,2,3,4,5,6); + P1 (C41203B.N1(IDENT_INT(1)..IDENT_INT(2)), + C41203B.N1(IDENT_INT(3)..IDENT_INT(4)), + C41203B.N1(IDENT_INT(5)..IDENT_INT(6)), "C41203B.N1"); + IF N1 /= (1,2,10,11,12,13) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER " & + "- C41203B.N1"); + END IF; + + IF N5.S(IDENT_INT(1)..IDENT_INT(5)) /= "ABCDE" THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N5"); + END IF; + N5.S(IDENT_INT(4)..IDENT_INT(6)) := "PQR"; + IF N5.S /= "ABCPQR" THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N5"); + END IF; + N5.S := "ABCDEF"; + P5 (N5.S(IDENT_INT(5)..IDENT_INT(6)), + N5.S(IDENT_INT(3)..IDENT_INT(4)), + N5.S(IDENT_INT(1)..IDENT_INT(2))); + IF N5.S /= "WZXYEF" THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N5"); + END IF; + + DECLARE + PACKAGE P IS + TYPE LIM IS LIMITED PRIVATE; + TYPE A IS ARRAY(INTEGER RANGE <>) OF LIM; + PROCEDURE INIT (V : OUT LIM; X,Y,Z : INTEGER); + PROCEDURE ASSIGN (ONE : OUT LIM; TWO : LIM); + FUNCTION "=" (ONE,TWO : A) RETURN BOOLEAN; + PRIVATE + TYPE LIM IS ARRAY(1..3) OF INTEGER; + END P; + + USE P; + + H : A(1..5); + + N6 : A(1..3); + + PACKAGE BODY P IS + PROCEDURE INIT (V : OUT LIM; X,Y,Z : INTEGER) IS + BEGIN + V := (X,Y,Z); + END INIT; + + PROCEDURE ASSIGN (ONE : OUT LIM; TWO : LIM) IS + BEGIN + ONE := TWO; + END ASSIGN; + + FUNCTION "=" (ONE,TWO : A) RETURN BOOLEAN IS + BEGIN + IF ONE(1) = TWO(2) AND ONE(2) = TWO(3) AND + ONE(3) = TWO(4) THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; + END "="; + END P; + + FUNCTION FR RETURN A IS + BEGIN + RETURN H; + END FR; + + BEGIN + INIT (H(1),1,2,3); + INIT (H(2),4,5,6); + INIT (H(3),7,8,9); + INIT (H(4),10,11,12); + INIT (H(5),13,14,15); + INIT (N6(1),0,0,0); + INIT (N6(2),0,0,0); + INIT (N6(3),0,0,0); + + ASSIGN (N6(1),H(2)); + ASSIGN (N6(2),H(3)); + ASSIGN (N6(3),H(4)); + + IF N6 /= FR(2..4) THEN + FAILED ("WRONG VALUE FROM LIMITED COMPONENT TYPE"); + END IF; + END; + END; + + RESULT; +END C41203B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41204a.ada b/gcc/testsuite/ada/acats/tests/c4/c41204a.ada new file mode 100644 index 000000000..0ad8439b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41204a.ada @@ -0,0 +1,86 @@ +-- C41204A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF A SLICE'S DISCRETE +-- RANGE IS NOT NULL, AND ITS LOWER OR UPPER BOUND IS NOT A +-- POSSIBLE INDEX FOR THE NAMED ARRAY. + +-- WKB 8/4/81 +-- EDS 7/14/98 AVOID OPTIMIZATION + +WITH REPORT; +USE REPORT; +PROCEDURE C41204A IS + +BEGIN + TEST ("C41204A", "ILLEGAL UPPER OR LOWER BOUNDS FOR A " & + "SLICE RAISES CONSTRAINT_ERROR"); + + DECLARE + + TYPE T IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + A : T (10..15) := (10,11,12,13,14,15); + B : T (-20..30); + + BEGIN + + BEGIN + B (IDENT_INT(9)..12) := A (IDENT_INT(9)..12); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1" & + INTEGER'IMAGE(B(10))); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 1"); + END; + + BEGIN + B (IDENT_INT(-12)..14) := A (IDENT_INT(-12)..14); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 2" & + INTEGER'IMAGE(B(10))); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 2"); + END; + + BEGIN + B (11..IDENT_INT(16)) := A (11..IDENT_INT(16)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 3" & + INTEGER'IMAGE(B(15))); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 3"); + END; + + BEGIN + B (17..20) := A (IDENT_INT(17)..IDENT_INT(20)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 4" & + INTEGER'IMAGE(B(17))); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 4"); + END; + END; + + RESULT; +END C41204A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41205a.ada b/gcc/testsuite/ada/acats/tests/c4/c41205a.ada new file mode 100644 index 000000000..220ae33cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41205a.ada @@ -0,0 +1,94 @@ +-- C41205A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE NAME PART OF A +-- SLICE DENOTES AN ACCESS OBJECT WHOSE VALUE IS NULL, AND +-- ALSO IF THE NAME IS A FUNCTION CALL DELIVERING NULL. + +-- WKB 8/6/81 +-- SPS 10/26/82 +-- EDS 07/14/98 AVOID OPTIMIZATION + +WITH REPORT; +USE REPORT; +PROCEDURE C41205A IS + +BEGIN + TEST ("C41205A", "CONSTRAINT_ERROR WHEN THE NAME PART OF A " & + "SLICE DENOTES A NULL ACCESS OBJECT OR A " & + "FUNCTION CALL DELIVERING NULL"); + + DECLARE + + TYPE T IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + SUBTYPE T1 IS T (1..5); + TYPE A1 IS ACCESS T1; + B : A1 := NEW T1' (1,2,3,4,5); + I : T (2..3); + + BEGIN + + IF EQUAL (3,3) THEN + B := NULL; + END IF; + + I := B(2..3); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1 " & INTEGER'IMAGE(I(2))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 1"); + + END; + + DECLARE + + TYPE T IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + SUBTYPE T2 IS T (1..5); + TYPE A2 IS ACCESS T2; + I : T (2..5); + + FUNCTION F RETURN A2 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN NULL; + END IF; + RETURN NEW T2' (1,2,3,4,5); + END F; + + BEGIN + + I := F(2..5); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 2 " & INTEGER'IMAGE(I(2))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 2"); + + END; + + RESULT; +END C41205A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41206a.ada b/gcc/testsuite/ada/acats/tests/c4/c41206a.ada new file mode 100644 index 000000000..b12e43d19 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41206a.ada @@ -0,0 +1,84 @@ +-- C41206A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A RANGE L..R, WHERE L=SUCC(R) CAN BE USED TO FORM +-- A NULL SLICE FROM AN ARRAY WHEN: +-- BOTH L AND R SATISFY THE INDEX CONSTRAINT; +-- L SATISFIES THE INDEX CONSTRAINT, R DOES NOT (BUT IT +-- BELONGS TO THE BASE TYPE OF THE INDEX); +-- L SATISFIES THE CONSTRAINT IMPOSED BY THE TYPE MARK OF +-- THE INDEX, BUT NOT THE CONSTRAINT ASSOCIATED WITH +-- THE INDEX; +-- THE ARRAY IS NULL, AND L IS IN THE RANGE OF THE INDEX SUBTYPE. + +-- WKB 8/10/81 + +WITH REPORT; +USE REPORT; +PROCEDURE C41206A IS + + TYPE SMALL IS RANGE 1..100; + TYPE T IS ARRAY (SMALL RANGE <> ) OF INTEGER; + SUBTYPE T1 IS T(5..10); + A : T1 := (5,6,7,8,9,10); + B : T(8..7) := (8..7 => 1); + +BEGIN + TEST ("C41206A", "USING A RANGE L..R, WHERE L=SUCC(R), " & + "TO FORM A NULL SLICE FROM AN ARRAY"); + + BEGIN + IF A (7..6) /= B OR A (SMALL(IDENT_INT(7))..6) /= B THEN + FAILED ("SLICE NOT NULL - 1"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED - 1"); + END; + + BEGIN + IF A (5..4) /= B OR A (SMALL(IDENT_INT(5))..4) /= B THEN + FAILED ("SLICE NOT NULL - 2"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED - 2"); + END; + + BEGIN + IF A (50..49) /= B OR A (SMALL(IDENT_INT(50))..49) /= B THEN + FAILED ("SLICE NOT NULL - 3"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED - 3"); + END; + + BEGIN + IF B (50..49) /= B OR B (SMALL(IDENT_INT(50))..49) /= B THEN + FAILED ("SLICE NOT NULL - 4"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED - 4"); + END; + + RESULT; +END C41206A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41207a.ada b/gcc/testsuite/ada/acats/tests/c4/c41207a.ada new file mode 100644 index 000000000..6f1807f4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41207a.ada @@ -0,0 +1,69 @@ +-- C41207A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE DISCRETE RANGE IN A SLICE CAN HAVE THE FORM +-- A'RANGE, WHERE A IS A CONSTRAINED ARRAY SUBTYPE OR AN ARRAY +-- OBJECT. + +-- HISTORY: +-- BCB 07/13/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C41207A IS + + TYPE ARR IS ARRAY(INTEGER RANGE <>) OF INTEGER; + + SUBTYPE A1 IS ARR(1..5); + + ARR_VAR : ARR(1..10) := (90,91,92,93,94,95,96,97,98,99); + + A2 : ARRAY(1..5) OF INTEGER := (80,81,82,83,84); + +BEGIN + TEST ("C41207A", "CHECK THAT THE DISCRETE RANGE IN A SLICE CAN " & + "HAVE THE FORM A'RANGE, WHERE A IS A " & + "CONSTRAINED ARRAY SUBTYPE OR AN ARRAY OBJECT"); + + ARR_VAR (A1'RANGE) := (1,2,3,4,5); + + IF NOT (EQUAL(ARR_VAR(1),1) AND EQUAL(ARR_VAR(2),2) AND + EQUAL(ARR_VAR(3),3) AND EQUAL(ARR_VAR(4),4) AND + EQUAL(ARR_VAR(5),5)) THEN + FAILED ("IMPROPER RESULT FROM SLICE ASSIGNMENT USING THE " & + "RANGE OF A CONSTRAINED ARRAY SUBTYPE"); + END IF; + + ARR_VAR (A2'RANGE) := (6,7,8,9,10); + + IF (NOT EQUAL(ARR_VAR(1),6) OR NOT EQUAL(ARR_VAR(2),7) OR + NOT EQUAL(ARR_VAR(3),8) OR NOT EQUAL(ARR_VAR(4),9) OR + NOT EQUAL(ARR_VAR(5),10)) THEN + FAILED ("IMPROPER RESULT FROM SLICE ASSIGNMENT USING THE " & + "RANGE OF AN ARRAY OBJECT"); + END IF; + + RESULT; +END C41207A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41301a.ada b/gcc/testsuite/ada/acats/tests/c4/c41301a.ada new file mode 100644 index 000000000..78017f5dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41301a.ada @@ -0,0 +1,216 @@ +-- C41301A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.R MAY BE USED TO DENOTE A RECORD COMPONENT, +-- WHERE R IS THE IDENTIFIER OF SUCH COMPONENT, AND L MAY BE ANY OF +-- THE FOLLOWING: +-- AN IDENTIFIER DENOTING A RECORD OBJECT - X2; +-- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE DESIGNATES +-- A RECORD OBJECT - X3; +-- A FUNCTION CALL DELIVERING A RECORD VALUE - F1; +-- A FUNCTION CALL DELIVERING AN ACCESS VALUE DESIGNATING A +-- RECORD OBJECT - F2; +-- AN INDEXED COMPONENT - X4; +-- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT +-- ENCLOSING THE IDENTIFIER'S DECLARATION - C41301A.X1; +-- A SELECTED COMPONENT DENOTING A RECORD (WHICH IS A COMPONENT +-- OF ANOTHER RECORD) - X5. + +-- WKB 8/13/81 +-- JRK 8/17/81 +-- SPS 10/26/82 + +WITH REPORT; +USE REPORT; +PROCEDURE C41301A IS + + TYPE T1 IS + RECORD + A : INTEGER; + B : BOOLEAN; + C : BOOLEAN; + END RECORD; + X1 : T1 := (A=>1, B=>TRUE, C=>FALSE); + +BEGIN + TEST ("C41301A", "CHECK THAT THE NOTATION L.R MAY BE USED TO " & + "DENOTE A RECORD COMPONENT, WHERE R IS THE " & + "IDENTIFIER AND L MAY BE OF CERTAIN FORMS"); + + DECLARE + + TYPE T2 (DISC : INTEGER := 0) IS + RECORD + D : BOOLEAN; + E : INTEGER; + F : BOOLEAN; + CASE DISC IS + WHEN 1 => + G : BOOLEAN; + WHEN 2 => + H : INTEGER; + WHEN OTHERS => + NULL; + END CASE; + END RECORD; + X2 : T2(2) := (DISC=>2, D=>TRUE, E=>3, F=>FALSE, H=>1); + + TYPE T3 IS ACCESS T1; + X3 : T3 := NEW T1' (A=>1, B=>TRUE, C=>FALSE); + + TYPE T4 IS ARRAY (1..3) OF T1; + X4 : T4 := (1 => (1, TRUE, FALSE), + 2 => (2, FALSE, TRUE), + 3 => (3, TRUE, FALSE)); + + TYPE T5 IS + RECORD + I : INTEGER; + J : T1; + END RECORD; + X5 : T5 := (I => 5, J => (6, FALSE, TRUE)); + + FUNCTION F1 RETURN T2 IS + BEGIN + RETURN (DISC=>1, D=>FALSE, E=>3, F=>TRUE, G=>FALSE); + END F1; + + FUNCTION F2 RETURN T3 IS + BEGIN + RETURN X3; + END F2; + + PROCEDURE P1 (X : IN BOOLEAN; Y : IN OUT INTEGER; + Z : OUT BOOLEAN; W : STRING) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - " & W); + END IF; + IF Y /= 1 THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W); + END IF; + Y := 10; + Z := TRUE; + END P1; + + PROCEDURE P2 (X : IN INTEGER) IS + BEGIN + IF X /= 1 THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - F1"); + END IF; + END P2; + + BEGIN + + IF X2.E /= 3 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - X2"); + END IF; + X2.E := 5; + IF X2 /= (2, TRUE, 5, FALSE, 1) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - X2"); + END IF; + X2 := (DISC=>2, D=>TRUE, E=>3, F=>FALSE, H=>1); + P1 (X2.D, X2.H, X2.F, "X2"); + IF X2 /= (2, TRUE, 3, TRUE, 10) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - X2"); + END IF; + + IF X3.C /= FALSE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - X3"); + END IF; + X3.A := 5; + IF X3.ALL /= (5, TRUE, FALSE) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - X3"); + END IF; + X3 := NEW T1 '(A=>1, B=>TRUE, C=>FALSE); + P1 (X3.B, X3.A, X3.C, "X3"); + IF X3.ALL /= (10, TRUE, TRUE) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - X3"); + END IF; + + IF F1.G /= FALSE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F1"); + END IF; + P2 (F1.DISC); + + X3 := NEW T1' (A=>3, B=>FALSE, C=>TRUE); + IF F2.B /= FALSE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F2"); + END IF; + F2.A := 4; + IF X3.ALL /= (4, FALSE, TRUE) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - F2"); + END IF; + X3 := NEW T1' (A=>1, B=>FALSE, C=>TRUE); + P1 (F2.C, F2.A, F2.B, "F2"); + IF X3.ALL /= (10, TRUE, TRUE) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2"); + END IF; + + IF X4(2).C /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - X4"); + END IF; + X4(3).A := 4; + IF X4 /= ((1,TRUE,FALSE), (2,FALSE,TRUE), (4,TRUE,FALSE)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - X4"); + END IF; + X4 := (1 => (2,TRUE,FALSE), 2 => (1,FALSE,TRUE), + 3 => (3,TRUE,FALSE)); + P1 (X4(3).B, X4(2).A, X4(1).C, "X4"); + IF X4 /= ((2,TRUE,TRUE), (10,FALSE,TRUE), (3,TRUE,FALSE)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - X4"); + END IF; + + X1 := (A=>1, B=>FALSE, C=>TRUE); + IF C41301A.X1.C /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - C41301A.X1"); + END IF; + C41301A.X1.B := TRUE; + IF X1 /= (1, TRUE, TRUE) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - C41301A.X1"); + END IF; + X1 := (A=>1, B=>FALSE, C=>TRUE); + P1 (C41301A.X1.C, C41301A.X1.A, C41301A.X1.B, "C41301A.X1"); + IF X1 /= (10, TRUE, TRUE) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - " & + "C41301A.X1"); + END IF; + + IF X5.J.C /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - X5"); + END IF; + X5.J.C := FALSE; + IF X5 /= (5, (6, FALSE, FALSE)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - X5"); + END IF; + X5 := (I => 5, J => (A=>1, B=>TRUE, C=>FALSE)); + P1 (X5.J.B, X5.J.A, X5.J.C, "X5"); + IF X5 /= (5, (10, TRUE, TRUE)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - X5"); + END IF; + + END; + + RESULT; +END C41301A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303a.ada b/gcc/testsuite/ada/acats/tests/c4/c41303a.ada new file mode 100644 index 000000000..4224effd7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303a.ada @@ -0,0 +1,120 @@ +-- C41303A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || XXXXXXXXX | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/20/82 +-- RM 1/25/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303A IS + + +BEGIN + + TEST ( "C41303A" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING A RECORD, AN ARRAY, OR A SCALAR"); + + + ------------------------------------------------------------------- + -------------------- ACCESS TO RECORD --------------------------- + + DECLARE + + TYPE REC IS + + RECORD + A , B , C : INTEGER ; + END RECORD ; + + REC_CONST : REC := ( 7 , 8 , 9 ); + REC_VAR : REC := REC_CONST ; + + TYPE ACC_REC IS ACCESS REC ; + + ACC_REC_VAR : ACC_REC := NEW REC'( 17 , 18 , 19 ); + + BEGIN + + REC_VAR := ACC_REC_VAR.ALL ; + + IF REC_VAR /= ( 17 , 18 , 19 ) + THEN + FAILED( "ACC. RECORD, RIGHT SIDE OF ASSIGN.,WRONG VAL."); + END IF; + + + ACC_REC_VAR.ALL := REC_CONST ; + + IF ACC_REC_VAR.ALL /= ( 7 , 8 , 9 ) + THEN + FAILED( "ACC. RECORD, LEFT SIDE OF ASSIGN.,WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303b.ada b/gcc/testsuite/ada/acats/tests/c4/c41303b.ada new file mode 100644 index 000000000..cb6c1ab6b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303b.ada @@ -0,0 +1,117 @@ +-- C41303B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || XXXXXXXXX | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/20/82 +-- RM 1/25/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303B IS + + +BEGIN + + TEST ( "C41303B" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING A RECORD, AN ARRAY, OR A SCALAR"); + + + ------------------------------------------------------------------- + -------------------- ACCESS TO ARRAY ---------------------------- + + DECLARE + + TYPE ARR IS ARRAY(1..2) OF BOOLEAN ; + + ARR_CONST : ARR := ( TRUE , FALSE ); + ARR_VAR : ARR := ARR_CONST ; + + TYPE ACC_ARR IS ACCESS ARR ; + + ACC_ARR_VAR : ACC_ARR := NEW ARR'( FALSE , TRUE ); + + BEGIN + + ARR_VAR := ACC_ARR_VAR.ALL ; + + IF ARR_VAR /= ( FALSE , TRUE ) + THEN + FAILED( "ACC. ARRAY, RIGHT SIDE OF ASSIGN., WRONG VAL."); + END IF; + + + ACC_ARR_VAR.ALL := ARR_CONST ; + + IF ACC_ARR_VAR.ALL /= ( TRUE , FALSE ) + THEN + FAILED( "ACC. ARRAY, LEFT SIDE OF ASSIGN., WRONG VAL." ); + END IF; + + + END ; + + + ------------------------------------------------------------------- + + RESULT; + + +END C41303B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303c.ada b/gcc/testsuite/ada/acats/tests/c4/c41303c.ada new file mode 100644 index 000000000..d68872539 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303c.ada @@ -0,0 +1,116 @@ +-- C41303C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || XXXXXXXXX | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/20/82 +-- RM 1/25/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303C IS + + +BEGIN + + TEST ( "C41303C" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING A RECORD, AN ARRAY, OR A SCALAR"); + + + ------------------------------------------------------------------- + -------------------- ACCESS TO SCALAR --------------------------- + + DECLARE + + TYPE NEWINT IS NEW INTEGER ; + + NEWINT_CONST : NEWINT := 813 ; + NEWINT_VAR : NEWINT := NEWINT_CONST ; + + TYPE ACC_NEWINT IS ACCESS NEWINT ; + + ACC_NEWINT_VAR : ACC_NEWINT := NEW NEWINT'( 707 ); + + BEGIN + + NEWINT_VAR := ACC_NEWINT_VAR.ALL ; + + IF NEWINT_VAR /= ( 707 ) + THEN + FAILED( "ACC. NEWINT, RIGHT SIDE OF ASSIGN.,WRONG VAL."); + END IF; + + + ACC_NEWINT_VAR.ALL := NEWINT_CONST ; + + IF ACC_NEWINT_VAR.ALL /= 813 + THEN + FAILED( "ACC. NEWINT, LEFT SIDE OF ASSIGN.,WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303e.ada b/gcc/testsuite/ada/acats/tests/c4/c41303e.ada new file mode 100644 index 000000000..f49dae27c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303e.ada @@ -0,0 +1,124 @@ +-- C41303E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || XXXXXXXXX | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/20/82 +-- RM 1/25/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303E IS + + +BEGIN + + TEST ( "C41303E" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING ANOTHER ACCESS OBJECT" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO RECORD ---------------------- + + DECLARE + + TYPE REC IS + + RECORD + A , B , C : INTEGER ; + END RECORD ; + + + TYPE ACCREC IS ACCESS REC ; + + ACCREC_CONST : ACCREC := NEW REC'( 7 , 8 , 9 ); + ACCREC_VAR : ACCREC := ACCREC_CONST ; + ACCREC_CONST2 : ACCREC := NEW REC'( 17 , 18 , 19 ); + + TYPE ACC_ACCREC IS ACCESS ACCREC ; + + ACC_ACCREC_VAR : ACC_ACCREC := NEW ACCREC'(ACCREC_CONST2); + + BEGIN + + ACCREC_VAR := ACC_ACCREC_VAR.ALL ; + + IF ACCREC_VAR /= ACCREC_CONST2 + THEN + FAILED( "ACC2 RECORD, RIGHT SIDE OF ASSIGN.,WRONG VAL."); + END IF; + + + ACC_ACCREC_VAR.ALL := ACCREC_CONST ; + + IF ACCREC_CONST /= ACC_ACCREC_VAR.ALL + THEN + FAILED( "ACC2 RECORD, LEFT SIDE OF ASSIGN.,WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303E; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303f.ada b/gcc/testsuite/ada/acats/tests/c4/c41303f.ada new file mode 100644 index 000000000..aa474cd8d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303f.ada @@ -0,0 +1,117 @@ +-- C41303F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || XXXXXXXXX | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/20/82 +-- RM 1/25/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303F IS + +BEGIN + + TEST ( "C41303F" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING ANOTHER ACCESS OBJECT" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO ARRAY ----------------------- + + DECLARE + + TYPE ARR IS ARRAY(1..2) OF BOOLEAN ; + TYPE ACCARR IS ACCESS ARR ; + + ACCARR_CONST : ACCARR := NEW ARR'( TRUE , FALSE ); + ACCARR_VAR : ACCARR := ACCARR_CONST ; + ACCARR_CONST2 : ACCARR := NEW ARR'( FALSE , TRUE ); + + TYPE ACC_ACCARR IS ACCESS ACCARR ; + + ACC_ACCARR_VAR : ACC_ACCARR := NEW ACCARR'(ACCARR_CONST2); + + BEGIN + + ACCARR_VAR := ACC_ACCARR_VAR.ALL ; + + IF ACCARR_VAR /= ACCARR_CONST2 + THEN + FAILED( "ACC2 ARRAY, RIGHT SIDE OF ASSIGN., WRONG VAL."); + END IF; + + + ACC_ACCARR_VAR.ALL := ACCARR_CONST ; + + IF ACCARR_CONST /= ACC_ACCARR_VAR.ALL + THEN + FAILED( "ACC2 ARRAY, LEFT SIDE OF ASSIGN., WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303F; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303g.ada b/gcc/testsuite/ada/acats/tests/c4/c41303g.ada new file mode 100644 index 000000000..39a6aa3f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303g.ada @@ -0,0 +1,121 @@ +-- C41303G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || XXXXXXXXX | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/20/82 +-- RM 1/25/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303G IS + + +BEGIN + + TEST ( "C41303G" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING ANOTHER ACCESS OBJECT" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO SCALAR ---------------------- + + DECLARE + + TYPE NEWINT IS NEW INTEGER ; + + TYPE ACCNEWINT IS ACCESS NEWINT ; + + ACCNEWINT_CONST : ACCNEWINT := NEW NEWINT'( 813 ); + ACCNEWINT_VAR : ACCNEWINT := ACCNEWINT_CONST ; + ACCNEWINT_CONST2 : ACCNEWINT := NEW NEWINT'( 707 ); + + TYPE ACC_ACCNEWINT IS ACCESS ACCNEWINT ; + + ACC_ACCNEWINT_VAR : ACC_ACCNEWINT := NEW ACCNEWINT'( + ACCNEWINT_CONST2 + ); + + BEGIN + + ACCNEWINT_VAR := ACC_ACCNEWINT_VAR.ALL ; + + IF ACCNEWINT_VAR /= ACCNEWINT_CONST2 + THEN + FAILED( "ACC2 NEWINT, RIGHT SIDE OF ASSIGN.,WRONG VAL."); + END IF; + + + ACC_ACCNEWINT_VAR.ALL := ACCNEWINT_CONST ; + + IF ACCNEWINT_CONST /= ACC_ACCNEWINT_VAR.ALL + THEN + FAILED( "ACC2 NEWINT, LEFT SIDE OF ASSIGN.,WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303G; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303i.ada b/gcc/testsuite/ada/acats/tests/c4/c41303i.ada new file mode 100644 index 000000000..1c0aff25a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303i.ada @@ -0,0 +1,127 @@ +-- C41303I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || XXXXXXXXX | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/20/82 +-- RM 1/25/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303I IS + + +BEGIN + + TEST ( "C41303I" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" & + " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" & + " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" & + " ACCEPTED" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO RECORD ---------------------- + + DECLARE + + TYPE REC IS + + RECORD + A , B , C : INTEGER ; + END RECORD ; + + + REC_CONST : REC := ( 7 , 8 , 9 ); + REC_VAR : REC := REC_CONST ; + REC_CONST2 : REC := ( 17 , 18 , 19 ); + + TYPE ACCREC IS ACCESS REC ; + + TYPE ACC_ACCREC IS ACCESS ACCREC ; + + ACC_ACCREC_VAR : ACC_ACCREC := NEW ACCREC'( + NEW REC'( REC_CONST2 ) + ); + + BEGIN + + REC_VAR := ACC_ACCREC_VAR.ALL.ALL ; + + IF REC_VAR /= REC_CONST2 + THEN + FAILED( "ACC2 RECORD,RIGHT SIDE OF ASSIGN., WRONG VAL."); + END IF; + + + ACC_ACCREC_VAR.ALL.ALL := REC_CONST ; + + IF ( 7 , 8 , 9 ) /= ACC_ACCREC_VAR.ALL.ALL + THEN + FAILED( "ACC2 RECORD, LEFT SIDE OF ASSIGN., WRONG VAL."); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303I; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303j.ada b/gcc/testsuite/ada/acats/tests/c4/c41303j.ada new file mode 100644 index 000000000..fad2a394e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303j.ada @@ -0,0 +1,122 @@ +-- C41303J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || XXXXXXXXX | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/20/82 +-- RM 1/25/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303J IS + + +BEGIN + + TEST ( "C41303J" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" & + " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" & + " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" & + " ACCEPTED" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO ARRAY ----------------------- + + DECLARE + + TYPE ARR IS ARRAY(1..2) OF BOOLEAN ; + + ARR_CONST : ARR := ( TRUE , FALSE ); + ARR_VAR : ARR := ARR_CONST ; + ARR_CONST2 : ARR := ( FALSE , TRUE ); + + TYPE ACCARR IS ACCESS ARR ; + + TYPE ACC_ACCARR IS ACCESS ACCARR ; + + ACC_ACCARR_VAR : ACC_ACCARR := NEW ACCARR'( + NEW ARR'( ARR_CONST2 ) + ); + + BEGIN + + ARR_VAR := ACC_ACCARR_VAR.ALL.ALL ; + + IF ARR_VAR /= ARR_CONST2 + THEN + FAILED( "ACC2 ARRAY, RIGHT SIDE OF ASSIGN., WRONG VAL."); + END IF; + + + ACC_ACCARR_VAR.ALL.ALL := ARR_CONST ; + + IF ( TRUE , FALSE ) /= ACC_ACCARR_VAR.ALL.ALL + THEN + FAILED( "ACC2 ARRAY, LEFT SIDE OF ASSIGN., WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303J; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303k.ada b/gcc/testsuite/ada/acats/tests/c4/c41303k.ada new file mode 100644 index 000000000..bb6f2a785 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303k.ada @@ -0,0 +1,124 @@ +-- C41303K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || XXXXXXXXX | +-- ============================================================ + + +-- RM 1/20/82 +-- RM 1/25/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303K IS + + +BEGIN + + TEST ( "C41303K" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" & + " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" & + " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" & + " ACCEPTED" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO SCALAR ---------------------- + + DECLARE + + TYPE NEWINT IS NEW INTEGER ; + + NEWINT_CONST : NEWINT := ( 813 ); + NEWINT_VAR : NEWINT := NEWINT_CONST ; + NEWINT_CONST2 : NEWINT := ( 707 ); + + TYPE ACCNEWINT IS ACCESS NEWINT ; + + TYPE ACC_ACCNEWINT IS ACCESS ACCNEWINT ; + + ACC_ACCNEWINT_VAR : ACC_ACCNEWINT := NEW ACCNEWINT'( + NEW NEWINT' ( + NEWINT_CONST2 + ) + ); + + BEGIN + + NEWINT_VAR := ACC_ACCNEWINT_VAR.ALL.ALL ; + + IF NEWINT_VAR /= NEWINT_CONST2 + THEN + FAILED( "ACC2 NEWINT,RIGHT SIDE OF ASSIGN., WRONG VAL."); + END IF; + + + ACC_ACCNEWINT_VAR.ALL.ALL := NEWINT_CONST ; + + IF NEWINT_CONST /= ACC_ACCNEWINT_VAR.ALL.ALL + THEN + FAILED( "ACC2 NEWINT,LEFT SIDE OF ASSIGN., WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303K; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303m.ada b/gcc/testsuite/ada/acats/tests/c4/c41303m.ada new file mode 100644 index 000000000..f0c13d3eb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303m.ada @@ -0,0 +1,150 @@ +-- C41303M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | XXXXXXXXX +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/22/82 +-- RM 1/26/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303M IS + + +BEGIN + + TEST ( "C41303M" , "CHECK THAT L.ALL , WHERE L IS THE NAME OF" + & " AN ACCESS OBJECT DESIGNATING A RECORD, AN" + & " ARRAY, OR A SCALAR, IS ALLOWED AS" + & " ACTUAL PARAMETER OF ANY MODE" ); + + + ------------------------------------------------------------------- + -------------------- ACCESS TO RECORD --------------------------- + + DECLARE + + TYPE REC IS + + RECORD + A , B , C : INTEGER ; + END RECORD ; + + REC_CONST : REC := ( 7 , 8 , 9 ); + REC_VAR : REC := REC_CONST ; + REC_VAR0 : REC := REC_CONST ; + + TYPE ACC_REC IS ACCESS REC ; + + ACC_REC_VAR : ACC_REC := NEW REC'( 17 , 18 , 19 ); + ACC_REC_VAR0 : ACC_REC := NEW REC'( 17 , 18 , 19 ); + + + PROCEDURE R_ASSIGN( R_IN : IN REC ; + R_INOUT : IN OUT REC ) IS + BEGIN + REC_VAR := R_IN ; + REC_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT REC ; + L_INOUT : IN OUT REC ) IS + BEGIN + L_OUT := REC_CONST ; + L_INOUT := REC_CONST ; + END ; + + BEGIN + + R_ASSIGN( ACC_REC_VAR.ALL , ACC_REC_VAR0.ALL ); + + IF REC_VAR /= ( 17 , 18 , 19 ) + THEN + FAILED( "ACC. RECORD, RIGHT SIDE (1), WRONG VAL."); + END IF; + + IF REC_VAR0 /= ( 17 , 18 , 19 ) + THEN + FAILED( "ACC. RECORD, RIGHT SIDE (2), WRONG VAL."); + END IF; + + + L_ASSIGN( ACC_REC_VAR.ALL , ACC_REC_VAR0.ALL ); + + IF ACC_REC_VAR.ALL /= ( 7 , 8 , 9 ) + THEN + FAILED( "ACC. RECORD, LEFT SIDE (1), WRONG VAL." ); + END IF; + + + IF ACC_REC_VAR0.ALL /= ( 7 , 8 , 9 ) + THEN + FAILED( "ACC. RECORD, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303M; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303n.ada b/gcc/testsuite/ada/acats/tests/c4/c41303n.ada new file mode 100644 index 000000000..431d01e6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303n.ada @@ -0,0 +1,147 @@ +-- C41303N.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | XXXXXXXXX +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/22/82 +-- RM 1/26/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303N IS + + +BEGIN + + TEST ( "C41303N" , "CHECK THAT L.ALL , WHERE L IS THE NAME OF" + & " AN ACCESS OBJECT DESIGNATING A RECORD, AN" + & " ARRAY, OR A SCALAR, IS ALLOWED AS" + & " ACTUAL PARAMETER OF ANY MODE" ); + + + ------------------------------------------------------------------- + -------------------- ACCESS TO ARRAY ---------------------------- + + DECLARE + + TYPE ARR IS ARRAY(1..2) OF BOOLEAN ; + + ARR_CONST : ARR := ( TRUE , FALSE ); + ARR_VAR : ARR := ARR_CONST ; + ARR_VAR0 : ARR := ARR_CONST ; + + TYPE ACC_ARR IS ACCESS ARR ; + + ACC_ARR_VAR : ACC_ARR := NEW ARR'( FALSE , TRUE ); + ACC_ARR_VAR0 : ACC_ARR := NEW ARR'( FALSE , TRUE ); + + + PROCEDURE R_ASSIGN( R_IN : IN ARR ; + R_INOUT : IN OUT ARR ) IS + BEGIN + ARR_VAR := R_IN ; + ARR_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT ARR ; + L_INOUT : IN OUT ARR ) IS + BEGIN + L_OUT := ARR_CONST ; + L_INOUT := ARR_CONST ; + END ; + + BEGIN + + + R_ASSIGN( ACC_ARR_VAR.ALL , ACC_ARR_VAR0.ALL ); + + IF ARR_VAR /= ( FALSE , TRUE ) + THEN + FAILED( "ACC. ARRAY, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF ARR_VAR0 /= ( FALSE , TRUE ) + THEN + FAILED( "ACC. ARRAY, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_ARR_VAR.ALL , ACC_ARR_VAR0.ALL ); + + IF ACC_ARR_VAR.ALL /= ( TRUE , FALSE ) + THEN + FAILED( "ACC. ARRAY, LEFT SIDE (1), WRONG VAL." ); + END IF; + + + IF ACC_ARR_VAR0.ALL /= ( TRUE , FALSE ) + THEN + FAILED( "ACC. ARRAY, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303N; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303o.ada b/gcc/testsuite/ada/acats/tests/c4/c41303o.ada new file mode 100644 index 000000000..8f488bde6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303o.ada @@ -0,0 +1,145 @@ +-- C41303O.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | XXXXXXXXX +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/27/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303O IS + + +BEGIN + + TEST ( "C41303O" , "CHECK THAT L.ALL , WHERE L IS THE NAME OF" + & " AN ACCESS OBJECT DESIGNATING A RECORD, AN" + & " ARRAY, OR A SCALAR, IS ALLOWED AS" + & " ACTUAL PARAMETER OF ANY MODE" ); + + + ------------------------------------------------------------------- + -------------------- ACCESS TO SCALAR --------------------------- + + DECLARE + + TYPE NEWINT IS NEW INTEGER ; + + NEWINT_CONST : NEWINT := 813 ; + NEWINT_VAR : NEWINT := NEWINT_CONST ; + NEWINT_VAR0 : NEWINT := NEWINT_CONST ; + + TYPE ACC_NEWINT IS ACCESS NEWINT ; + + ACC_NEWINT_VAR : ACC_NEWINT := NEW NEWINT'( 707 ); + ACC_NEWINT_VAR0 : ACC_NEWINT := NEW NEWINT'( 707 ); + + + PROCEDURE R_ASSIGN( R_IN : IN NEWINT ; + R_INOUT : IN OUT NEWINT ) IS + BEGIN + NEWINT_VAR := R_IN ; + NEWINT_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT NEWINT ; + L_INOUT : IN OUT NEWINT ) IS + BEGIN + L_OUT := NEWINT_CONST ; + L_INOUT := NEWINT_CONST ; + END ; + + + BEGIN + + R_ASSIGN( ACC_NEWINT_VAR.ALL , ACC_NEWINT_VAR0.ALL ); + + IF NEWINT_VAR /= ( 707 ) + THEN + FAILED( "ACC. NEWINT, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF NEWINT_VAR0 /= ( 707 ) + THEN + FAILED( "ACC. NEWINT, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_NEWINT_VAR.ALL , ACC_NEWINT_VAR0.ALL ); + + IF ACC_NEWINT_VAR.ALL /= 813 + THEN + FAILED( "ACC. NEWINT, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF ACC_NEWINT_VAR0.ALL /= 813 + THEN + FAILED( "ACC. NEWINT, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303O; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303q.ada b/gcc/testsuite/ada/acats/tests/c4/c41303q.ada new file mode 100644 index 000000000..bf8756240 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303q.ada @@ -0,0 +1,152 @@ +-- C41303Q.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | XXXXXXXXX +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/28/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303Q IS + + +BEGIN + + TEST ( "C41303Q" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING ANOTHER ACCESS OBJECT" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO RECORD ---------------------- + + DECLARE + + TYPE REC IS + + RECORD + A , B , C : INTEGER ; + END RECORD ; + + + TYPE ACCREC IS ACCESS REC ; + + ACCREC_CONST : ACCREC := NEW REC'( 7 , 8 , 9 ); + ACCREC_VAR : ACCREC := ACCREC_CONST ; + ACCREC_VAR0 : ACCREC := ACCREC_CONST ; + ACCREC_CONST2 : ACCREC := NEW REC'( 17 , 18 , 19 ); + + TYPE ACC_ACCREC IS ACCESS ACCREC ; + + ACC_ACCREC_VAR : ACC_ACCREC := NEW ACCREC'(ACCREC_CONST2); + ACC_ACCREC_VAR0 : ACC_ACCREC := NEW ACCREC'(ACCREC_CONST2); + + PROCEDURE R_ASSIGN( R_IN : IN ACCREC ; + R_INOUT : IN OUT ACCREC ) IS + BEGIN + ACCREC_VAR := R_IN ; + ACCREC_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT ACCREC ; + L_INOUT : IN OUT ACCREC ) IS + BEGIN + L_OUT := ACCREC_CONST ; + L_INOUT := ACCREC_CONST ; + END ; + + + BEGIN + + + R_ASSIGN( ACC_ACCREC_VAR.ALL , ACC_ACCREC_VAR0.ALL ); + + IF ACCREC_VAR /= ACCREC_CONST2 + THEN + FAILED( "ACC. RECORD, RIGHT SIDE (1), WRONG VAL."); + END IF; + + IF ACCREC_VAR0 /= ACCREC_CONST2 + THEN + FAILED( "ACC. RECORD, RIGHT SIDE (2), WRONG VAL."); + END IF; + + + L_ASSIGN( ACC_ACCREC_VAR.ALL , ACC_ACCREC_VAR0.ALL ); + + IF ACCREC_CONST /= ACC_ACCREC_VAR.ALL + THEN + FAILED( "ACC. RECORD, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF ACCREC_CONST /= ACC_ACCREC_VAR0.ALL + THEN + FAILED( "ACC. RECORD, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303Q; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303r.ada b/gcc/testsuite/ada/acats/tests/c4/c41303r.ada new file mode 100644 index 000000000..b219e3c74 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303r.ada @@ -0,0 +1,145 @@ +-- C41303R.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | XXXXXXXXX +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/28/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303R IS + +BEGIN + + TEST ( "C41303R" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING ANOTHER ACCESS OBJECT" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO ARRAY ----------------------- + + DECLARE + + TYPE ARR IS ARRAY(1..2) OF BOOLEAN ; + TYPE ACCARR IS ACCESS ARR ; + + ACCARR_CONST : ACCARR := NEW ARR'( TRUE , FALSE ); + ACCARR_VAR : ACCARR := ACCARR_CONST ; + ACCARR_VAR0 : ACCARR := ACCARR_CONST ; + ACCARR_CONST2 : ACCARR := NEW ARR'( FALSE , TRUE ); + + TYPE ACC_ACCARR IS ACCESS ACCARR ; + + ACC_ACCARR_VAR : ACC_ACCARR := NEW ACCARR'(ACCARR_CONST2); + ACC_ACCARR_VAR0 : ACC_ACCARR := NEW ACCARR'(ACCARR_CONST2); + + + PROCEDURE R_ASSIGN( R_IN : IN ACCARR ; + R_INOUT : IN OUT ACCARR ) IS + BEGIN + ACCARR_VAR := R_IN ; + ACCARR_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT ACCARR ; + L_INOUT : IN OUT ACCARR ) IS + BEGIN + L_OUT := ACCARR_CONST ; + L_INOUT := ACCARR_CONST ; + END ; + + + BEGIN + + R_ASSIGN( ACC_ACCARR_VAR.ALL, ACC_ACCARR_VAR0.ALL ); + + IF ACCARR_VAR /= ACCARR_CONST2 + THEN + FAILED( "ACC2 ARRAY, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF ACCARR_VAR0 /= ACCARR_CONST2 + THEN + FAILED( "ACC2 ARRAY, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_ACCARR_VAR.ALL , ACC_ACCARR_VAR0.ALL ); + + IF ACCARR_CONST /= ACC_ACCARR_VAR.ALL + THEN + FAILED( "ACC2. ARRAY, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF ACCARR_CONST /= ACC_ACCARR_VAR0.ALL + THEN + FAILED( "ACC2. ARRAY, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303R; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303s.ada b/gcc/testsuite/ada/acats/tests/c4/c41303s.ada new file mode 100644 index 000000000..09ce2f49e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303s.ada @@ -0,0 +1,151 @@ +-- C41303S.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | XXXXXXXXX +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/28/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303S IS + + +BEGIN + + TEST ( "C41303S" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING ANOTHER ACCESS OBJECT" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO SCALAR ---------------------- + + DECLARE + + TYPE NEWINT IS NEW INTEGER ; + + TYPE ACCNEWINT IS ACCESS NEWINT ; + + ACCNEWINT_CONST : ACCNEWINT := NEW NEWINT'( 813 ); + ACCNEWINT_VAR : ACCNEWINT := ACCNEWINT_CONST ; + ACCNEWINT_VAR0 : ACCNEWINT := ACCNEWINT_CONST ; + ACCNEWINT_CONST2 : ACCNEWINT := NEW NEWINT'( 707 ); + + TYPE ACC_ACCNEWINT IS ACCESS ACCNEWINT ; + + ACC_ACCNEWINT_VAR : ACC_ACCNEWINT := NEW ACCNEWINT'( + ACCNEWINT_CONST2 + ); + + ACC_ACCNEWINT_VAR0 : ACC_ACCNEWINT := NEW ACCNEWINT'( + ACCNEWINT_CONST2 + ); + + PROCEDURE R_ASSIGN( R_IN : IN ACCNEWINT ; + R_INOUT : IN OUT ACCNEWINT ) IS + BEGIN + ACCNEWINT_VAR := R_IN ; + ACCNEWINT_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT ACCNEWINT ; + L_INOUT : IN OUT ACCNEWINT ) IS + BEGIN + L_OUT := ACCNEWINT_CONST ; + L_INOUT := ACCNEWINT_CONST ; + END ; + + + BEGIN + + R_ASSIGN( ACC_ACCNEWINT_VAR.ALL , ACC_ACCNEWINT_VAR0.ALL ); + + IF ACCNEWINT_VAR /= ACCNEWINT_CONST2 + THEN + FAILED( "ACC. NEWINT, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF ACCNEWINT_VAR0 /= ACCNEWINT_CONST2 + THEN + FAILED( "ACC. NEWINT, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_ACCNEWINT_VAR.ALL , ACC_ACCNEWINT_VAR0.ALL ); + + IF ACCNEWINT_CONST /= ACC_ACCNEWINT_VAR.ALL + THEN + FAILED( "ACC. NEWINT, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF ACCNEWINT_CONST /= ACC_ACCNEWINT_VAR0.ALL + THEN + FAILED( "ACC. NEWINT, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303S; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303u.ada b/gcc/testsuite/ada/acats/tests/c4/c41303u.ada new file mode 100644 index 000000000..92a76014e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303u.ada @@ -0,0 +1,158 @@ +-- C41303U.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | XXXXXXXXX +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/29/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303U IS + + +BEGIN + + TEST ( "C41303U" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" & + " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" & + " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" & + " ACCEPTED" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO RECORD ---------------------- + + DECLARE + + TYPE REC IS + + RECORD + A , B , C : INTEGER ; + END RECORD ; + + + REC_CONST : REC := ( 7 , 8 , 9 ); + REC_VAR : REC := REC_CONST ; + REC_VAR0 : REC := REC_CONST ; + REC_CONST2 : REC := ( 17 , 18 , 19 ); + + TYPE ACCREC IS ACCESS REC ; + + TYPE ACC_ACCREC IS ACCESS ACCREC ; + + ACC_ACCREC_VAR : ACC_ACCREC := NEW ACCREC'( + NEW REC'( REC_CONST2 ) + ); + + ACC_ACCREC_VAR0 : ACC_ACCREC := NEW ACCREC'( + NEW REC'( REC_CONST2 ) + ); + + + PROCEDURE R_ASSIGN( R_IN : IN REC ; + R_INOUT : IN OUT REC ) IS + BEGIN + REC_VAR := R_IN ; + REC_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT REC ; + L_INOUT : IN OUT REC ) IS + BEGIN + L_OUT := REC_CONST ; + L_INOUT := REC_CONST ; + END ; + + + BEGIN + + R_ASSIGN( ACC_ACCREC_VAR.ALL.ALL , ACC_ACCREC_VAR0.ALL.ALL ); + + IF REC_VAR /= REC_CONST2 + THEN + FAILED( "ACC2 RECORD, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF REC_VAR0 /= REC_CONST2 + THEN + FAILED( "ACC2 RECORD, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_ACCREC_VAR.ALL.ALL , ACC_ACCREC_VAR0.ALL.ALL ); + + IF ( 7 , 8 , 9 ) /= ACC_ACCREC_VAR.ALL.ALL + THEN + FAILED( "ACC2 RECORD, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF ( 7 , 8 , 9 ) /= ACC_ACCREC_VAR0.ALL.ALL + THEN + FAILED( "ACC2 RECORD, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303U; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303v.ada b/gcc/testsuite/ada/acats/tests/c4/c41303v.ada new file mode 100644 index 000000000..e6a6259af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303v.ada @@ -0,0 +1,155 @@ +-- C41303V.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | XXXXXXXXX +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ============================================================ + + +-- RM 1/29/82 +-- SPS 12/2/82 + + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303V IS + + +BEGIN + + TEST ( "C41303V" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" & + " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" & + " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" & + " ACCEPTED" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO ARRAY ----------------------- + + DECLARE + + TYPE ARR IS ARRAY(1..2) OF BOOLEAN ; + + ARR_CONST : ARR := ( TRUE , FALSE ); + ARR_VAR : ARR := ARR_CONST ; + ARR_VAR0 : ARR := ARR_CONST ; + ARR_CONST2 : ARR := ( FALSE , TRUE ); + + TYPE ACCARR IS ACCESS ARR ; + + TYPE ACC_ACCARR IS ACCESS ACCARR ; + + ACC_ACCARR_VAR : ACC_ACCARR := NEW ACCARR'( + NEW ARR'( ARR_CONST2 ) + ); + + ACC_ACCARR_VAR0 : ACC_ACCARR := NEW ACCARR'( + NEW ARR'( ARR_CONST2 ) + ); + + + PROCEDURE R_ASSIGN( R_IN : IN ARR ; + R_INOUT : IN OUT ARR ) IS + BEGIN + ARR_VAR := R_IN ; + ARR_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT ARR ; + L_INOUT : IN OUT ARR ) IS + BEGIN + L_OUT := ARR_CONST ; + L_INOUT := ARR_CONST ; + END ; + + + BEGIN + + + R_ASSIGN( ACC_ACCARR_VAR.ALL.ALL , ACC_ACCARR_VAR0.ALL.ALL ); + + IF ARR_VAR /= ARR_CONST2 + THEN + FAILED( "ACC2 ARRAY, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF ARR_VAR0 /= ARR_CONST2 + THEN + FAILED( "ACC2 ARRAY, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_ACCARR_VAR.ALL.ALL , ACC_ACCARR_VAR0.ALL.ALL ); + + IF ( TRUE , FALSE ) /= ACC_ACCARR_VAR.ALL.ALL + THEN + FAILED( "ACC2 ARRAY, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF ( TRUE , FALSE ) /= ACC_ACCARR_VAR0.ALL.ALL + THEN + FAILED( "ACC2 ARRAY, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303V; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41303w.ada b/gcc/testsuite/ada/acats/tests/c4/c41303w.ada new file mode 100644 index 000000000..a1bf58050 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303w.ada @@ -0,0 +1,159 @@ +-- C41303W.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN +-- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR +-- ANOTHER ACCESS OBJECT. +-- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH +-- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS +-- ACCEPTED. + + +-- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, +-- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + +-- || ASSIGNMT | PROC. PARAMETERS +-- || ():= :=() | IN OUT IN OUT +-- ========================||=============|==================== +-- ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 1 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | +-- ========================||=============|==================== +-- ACC ACC REC || | +-- --------------||-------------|-------------------- +-- 2 '.ALL' ACC ACC ARR || | +-- --------------||-------------|-------------------- +-- ACC ACC SCLR || | XXXXXXXXX +-- ============================================================ + + +-- RM 1/29/82 +-- SPS 12/2/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C41303W IS + + +BEGIN + + TEST ( "C41303W" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" & + " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" & + " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" & + " ACCEPTED" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO SCALAR ---------------------- + + DECLARE + + TYPE NEWINT IS NEW INTEGER ; + + NEWINT_CONST : NEWINT := ( 813 ); + NEWINT_VAR : NEWINT := NEWINT_CONST ; + NEWINT_VAR0 : NEWINT := NEWINT_CONST ; + NEWINT_CONST2 : NEWINT := ( 707 ); + + TYPE ACCNEWINT IS ACCESS NEWINT ; + + TYPE ACC_ACCNEWINT IS ACCESS ACCNEWINT ; + + ACC_ACCNEWINT_VAR : ACC_ACCNEWINT := NEW ACCNEWINT'( + NEW NEWINT' ( + NEWINT_CONST2 + ) + ); + + ACC_ACCNEWINT_VAR0 : ACC_ACCNEWINT := NEW ACCNEWINT'( + NEW NEWINT' ( + NEWINT_CONST2 + ) + ); + + PROCEDURE R_ASSIGN( R_IN : IN NEWINT ; + R_INOUT : IN OUT NEWINT ) IS + BEGIN + NEWINT_VAR := R_IN ; + NEWINT_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT NEWINT ; + L_INOUT : IN OUT NEWINT ) IS + BEGIN + L_OUT := NEWINT_CONST ; + L_INOUT := NEWINT_CONST ; + END ; + + + BEGIN + + + R_ASSIGN( ACC_ACCNEWINT_VAR.ALL.ALL , + ACC_ACCNEWINT_VAR0.ALL.ALL ); + + IF NEWINT_VAR /= NEWINT_CONST2 + THEN + FAILED( "ACC2 NEWINT, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF NEWINT_VAR0 /= NEWINT_CONST2 + THEN + FAILED( "ACC2 NEWINT, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_ACCNEWINT_VAR.ALL.ALL , + ACC_ACCNEWINT_VAR0.ALL.ALL ); + + IF NEWINT_CONST /= ACC_ACCNEWINT_VAR.ALL.ALL + THEN + FAILED( "ACC2 NEWINT, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF NEWINT_CONST /= ACC_ACCNEWINT_VAR0.ALL.ALL + THEN + FAILED( "ACC2 NEWINT, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41303W; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41304a.ada b/gcc/testsuite/ada/acats/tests/c4/c41304a.ada new file mode 100644 index 000000000..124d527c5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41304a.ada @@ -0,0 +1,119 @@ +-- C41304A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT L.R RAISES CONSTRAINT_ERROR WHEN: +-- L DENOTES AN ACCESS OBJECT HAVING THE VALUE NULL. +-- L IS A FUNCTION CALL DELIVERING THE ACCESS VALUE NULL. + +-- HISTORY: +-- WKB 08/14/81 +-- JRK 08/17/81 +-- SPS 10/26/82 +-- TBN 03/26/86 PUT THE NON-EXISTENT COMPONENT CASES INTO C41304B. +-- JET 01/05/88 MODIFIED HEADER FORMAT AND ADDED CODE TO PREVENT +-- OPTIMIZATION. + +WITH REPORT; USE REPORT; +PROCEDURE C41304A IS + + TYPE R IS + RECORD + I : INTEGER; + END RECORD; + + TYPE T IS ACCESS R; + +BEGIN + TEST ("C41304A", "CONSTRAINT_ERROR WHEN L IN L.R DENOTES A NULL " & + "ACCESS OBJECT OR A FUNCTION CALL DELIVERING " & + "NULL"); + + -------------------------------------------------- + + DECLARE + + A : T := NEW R' (I => 1); + J : INTEGER; + + BEGIN + + IF EQUAL (4, 4) THEN + A := NULL; + END IF; + + J := A.I; + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A NULL ACCESS " & + "OBJECT"); + + IF EQUAL (J,J) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR A NULL ACCESS " & + "OBJECT"); + + END; + + -------------------------------------------------- + + DECLARE + + J : INTEGER; + + FUNCTION F RETURN T IS + BEGIN + IF EQUAL (4, 4) THEN + RETURN NULL; + END IF; + RETURN NEW R' (I => 2); + END F; + + BEGIN + + J := F.I; + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " & + "DELIVERING A NULL ACCESS VALUE"); + + IF EQUAL (J,J) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " & + "DELIVERING A NULL ACCESS VALUE"); + + END; + + RESULT; +END C41304A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41304b.ada b/gcc/testsuite/ada/acats/tests/c4/c41304b.ada new file mode 100644 index 000000000..c6dec9c6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41304b.ada @@ -0,0 +1,198 @@ +-- C41304B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT L.R RAISES CONSTRAINT_ERROR WHEN: +-- L DENOTES A RECORD OBJECT SUCH THAT, FOR THE EXISTING +-- DISCRIMINANT VALUES, THE COMPONENT DENOTED BY R DOES +-- NOT EXIST. +-- L IS A FUNCTION CALL DELIVERING A RECORD VALUE SUCH THAT, +-- FOR THE EXISTING DISCRIMINANT VALUES, THE COMPONENT +-- DENOTED BY R DOES NOT EXIST. +-- L IS AN ACCESS OBJECT AND THE OBJECT DESIGNATED BY THE ACCESS +-- VALUE IS SUCH THAT COMPONENT R DOES NOT EXIST FOR THE +-- OBJECT'S CURRENT DISCRIMINANT VALUES. +-- L IS A FUNCTION CALL RETURNING AN ACCESS VALUE AND THE OBJECT +-- DESIGNATED BY THE ACCESS VALUE IS SUCH THAT COMPONENT R +-- DOES NOT EXIST FOR THE OBJECT'S CURRENT DISCRIMINANT +-- VALUES. + +-- HISTORY: +-- TBN 05/23/86 CREATED ORIGINAL TEST. +-- JET 01/08/88 MODIFIED HEADER FORMAT AND ADDED CODE TO +-- PREVENT OPTIMIZATION. + +WITH REPORT; USE REPORT; +PROCEDURE C41304B IS + + TYPE V (DISC : INTEGER := 0) IS + RECORD + CASE DISC IS + WHEN 1 => + X : INTEGER; + WHEN OTHERS => + Y : INTEGER; + END CASE; + END RECORD; + + TYPE T IS ACCESS V; + +BEGIN + TEST ("C41304B", "CHECK THAT L.R RAISES CONSTRAINT_ERROR WHEN " & + "THE COMPONENT DENOTED BY R DOES NOT EXIST"); + + DECLARE + + VR : V := (DISC => 0, Y => 4); + J : INTEGER; + + BEGIN + + IF EQUAL (4, 4) THEN + VR := (DISC => 1, X => 3); + END IF; + + J := VR.Y; + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A RECORD OBJECT"); + + -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J. + + IF EQUAL (J,3) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR A RECORD OBJECT"); + + END; + + -------------------------------------------------- + + DECLARE + + J : INTEGER; + + FUNCTION F RETURN V IS + BEGIN + IF EQUAL (4, 4) THEN + RETURN (DISC => 2, Y => 3); + END IF; + RETURN (DISC => 1, X => 4); + END F; + + BEGIN + + J := F.X; + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " & + "DELIVERING A RECORD VALUE"); + + -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J. + + IF EQUAL (J,3) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - 2"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " & + "DELIVERING A RECORD VALUE"); + + END; + + -------------------------------------------------- + + DECLARE + + A : T := NEW V' (DISC => 0, Y => 4); + J : INTEGER; + + BEGIN + + IF EQUAL (4, 4) THEN + A := NEW V' (DISC => 1, X => 3); + END IF; + + J := A.Y; + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR AN ACCESS OBJECT"); + + -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J. + + IF EQUAL (J,3) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - 3"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR AN ACCESS OBJECT"); + + END; + + -------------------------------------------------- + + DECLARE + + J : INTEGER; + + FUNCTION F RETURN T IS + BEGIN + IF EQUAL (4, 4) THEN + RETURN NEW V' (DISC => 2, Y => 3); + END IF; + RETURN NEW V' (DISC => 1, X => 4); + END F; + + BEGIN + + J := F.X; + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " & + "DELIVERING AN ACCESS VALUE"); + + -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J. + + IF EQUAL (J,3) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - 4"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " & + "DELIVERING AN ACCESS VALUE"); + + END; + + RESULT; +END C41304B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41306a.ada b/gcc/testsuite/ada/acats/tests/c4/c41306a.ada new file mode 100644 index 000000000..2521d7bd4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41306a.ada @@ -0,0 +1,104 @@ +-- C41306A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF F IS A FUNCTION RETURNING A TASK OF A TYPE HAVING +-- AN ENTRY E , AN ENTRY CALL OF THE FORM +-- +-- F.E +-- +-- IS PERMITTED. + + +-- RM 2/2/82 +-- ABW 7/16/82 + +WITH REPORT; +USE REPORT; +PROCEDURE C41306A IS + + +BEGIN + + TEST ( "C41306A" , "CHECK THAT IF F IS A FUNCTION RETURNING" & + " A TASK OF A TYPE HAVING AN ENTRY E , AN" & + " ENTRY CALL OF THE FORM F.E IS PERMITTED"); + + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + T1 : T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + ACCEPT E DO + X := IDENT_INT(16) ; + END E ; + END T ; + + FUNCTION F1 RETURN T IS + BEGIN + RETURN T1 ; + END F1 ; + + FUNCTION F2 (A,B : BOOLEAN) RETURN T IS + BEGIN + IF A AND B THEN NULL; END IF; + RETURN T1; + END F2; + + BEGIN + + F1.E ; -- X SET TO 17. + + IF X /= 17 THEN + FAILED("WRONG VALUE FOR GLOBAL VARIABLE - 1"); + END IF; + + X := 0; + F2(TRUE,TRUE).E; -- X SET TO 16. + -- X TO BE SET TO 16. + + IF X /= 16 THEN + FAILED("WRONG VALUE FOR GLOBAL VARIABLE - 2"); + END IF; + + END ; + + ------------------------------------------------------------------- + + RESULT; + + +END C41306A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41306b.ada b/gcc/testsuite/ada/acats/tests/c4/c41306b.ada new file mode 100644 index 000000000..390f978a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41306b.ada @@ -0,0 +1,217 @@ +-- C41306B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF F IS A FUNCTION RETURNING AN ACCESS VALUE DESIGNATING +-- A TASK OF A TYPE HAVING +-- AN ENTRY E , AN ENTRY CALL OF THE FORM +-- +-- F.ALL.E +-- +-- IS PERMITTED. + +-- RM 02/02/82 +-- ABW 07/16/82 +-- EG 05/28/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C41306B IS + +BEGIN + + TEST ( "C41306B" , "CHECK THAT IF F IS A FUNCTION RETURNING" & + " AN ACCESS VALUE DESIGNATING" & + " A TASK OF A TYPE HAVING AN ENTRY E , AN" & + " ENTRY CALL OF THE FORM F.ALL.E IS" & + " PERMITTED" ); + + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + TYPE A_T IS ACCESS T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + END T ; + + FUNCTION F1 RETURN A_T IS + A_T_VAR1 : A_T := NEW T ; + BEGIN + RETURN A_T_VAR1 ; + END F1 ; + + FUNCTION F2 (A, B : BOOLEAN) RETURN A_T IS + A_T_VAR2 : A_T := NEW T; + BEGIN + IF A AND B THEN + NULL; + END IF; + RETURN A_T_VAR2; + END F2; + + BEGIN + + F1.ALL.E ; -- THE ELABOR. OF F1 (BODY) ACTIVATES THE TASK, + -- WHICH PROCEEDS TO WAIT FOR ENTRY E TO + -- BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 . + + IF X /= 17 + THEN + FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (1)" ); + END IF; + + X := 0; + F2(TRUE, TRUE).ALL.E; -- THE ELABORATION OF F2 (BODY) + -- ACTIVATES THE TASK, WHICH + -- PROCEEDS TO WAIT FOR THE + -- ENTRY E TO BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE + -- SET TO 17. + + IF X /= 17 THEN + FAILED ("WRONG VALUE FOR GLOBAL VARIABLE (2)"); + END IF; + + END ; + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + TYPE A_T IS ACCESS T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + END T ; + + FUNCTION F3 RETURN A_T IS + BEGIN + RETURN NEW T ; + END F3; + + FUNCTION F4 (C, D : BOOLEAN) RETURN A_T IS + BEGIN + IF C AND D THEN + NULL; + END IF; + RETURN NEW T; + END F4; + + BEGIN + + F3.ALL.E ; -- THE ELABOR. OF F3 (BODY) ACTIVATES THE TASK, + -- WHICH PROCEEDS TO WAIT FOR ENTRY E TO + -- BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 . + + IF X /= 17 + THEN + FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (3)" ); + END IF; + + X := 0; + F4(TRUE, TRUE).ALL.E; -- THE ELABORATION OF F4 (BODY) + -- ACTIVATES THE TASK, WHICH + -- PROCEEDS TO WAIT FOR THE + -- ENTRY E TO BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE + -- SET TO 17. + + IF X /= 17 THEN + FAILED ("WRONG VALUE FOR GLOBAL VARIABLE (4)"); + END IF; + + END ; + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + TYPE A_T IS ACCESS T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + END T ; + + BEGIN + + DECLARE + + F3 : A_T := NEW T; + + BEGIN + + F3.ALL.E; + + -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 . + + IF X /= 17 THEN + FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (5)" ); + END IF; + + END; + + END ; + + ------------------------------------------------------------------- + + + RESULT; + + +END C41306B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41306c.ada b/gcc/testsuite/ada/acats/tests/c4/c41306c.ada new file mode 100644 index 000000000..dc715c881 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41306c.ada @@ -0,0 +1,215 @@ +-- C41306C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF F IS A FUNCTION RETURNING AN ACCESS VALUE DESIGNATING +-- A TASK OF A TYPE HAVING +-- AN ENTRY E , AN ENTRY CALL OF THE FORM +-- +-- F.E +-- +-- IS PERMITTED. + + +-- RM 02/02/82 +-- ABW 07/16/82 +-- EG 05/28/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C41306C IS + +BEGIN + + TEST ( "C41306C" , "CHECK THAT IF F IS A FUNCTION RETURNING" & + " AN ACCESS VALUE DESIGNATING" & + " A TASK OF A TYPE HAVING AN ENTRY E , AN" & + " ENTRY CALL OF THE FORM F.E IS PERMITTED" ); + + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + TYPE A_T IS ACCESS T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + END T ; + + FUNCTION F1 RETURN A_T IS + A_T_VAR1 : A_T := NEW T ; + BEGIN + RETURN A_T_VAR1 ; + END F1 ; + + FUNCTION F2 (A, B : BOOLEAN) RETURN A_T IS + A_T_VAR2 : A_T := NEW T; + BEGIN + IF A AND B THEN + NULL; + END IF; + RETURN A_T_VAR2; + END F2; + + BEGIN + + F1.E ; -- THE ELABOR. OF F1 (BODY) ACTIVATES THE TASK, + -- WHICH PROCEEDS TO WAIT FOR ENTRY E TO + -- BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 . + + IF X /= 17 + THEN + FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (1)" ); + END IF; + + X := 0; + F2(TRUE, TRUE).E; -- THE ELABORATION OF F2 (BODY) ACTIVATES + -- THE TASK, WHICH PROCEEDS TO WAIT FOR + -- ENTRY E TO BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE SET TO + -- 17. + + IF X /= 17 THEN + FAILED ("WRONG VALUE FOR GLOBAL VARIABLE (2)"); + END IF; + + END ; + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + TYPE A_T IS ACCESS T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + END T ; + + FUNCTION F3 RETURN A_T IS + BEGIN + RETURN NEW T ; + END F3; + + FUNCTION F4 (C, D : BOOLEAN) RETURN A_T IS + BEGIN + IF C AND D THEN + NULL; + END IF; + RETURN NEW T; + END F4; + + BEGIN + + F3.E ; -- THE ELABOR. OF F3 (BODY) ACTIVATES THE TASK, + -- WHICH PROCEEDS TO WAIT FOR ENTRY E TO + -- BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 . + + IF X /= 17 + THEN + FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (3)" ); + END IF; + + X := 0; + F4(TRUE, TRUE).E; -- THE ELABORATION OF F4 (BODY) ACTIVATES + -- THE TASK WHICH PROCEEDS TO WAIT FOR + -- ENTRY E TO BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE SET TO + -- 17. + + IF X /= 17 THEN + FAILED ("WRONG VALUE FOR GLOBAL VARIABLE (4)"); + END IF; + + END ; + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + TYPE A_T IS ACCESS T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + END T ; + + BEGIN + + DECLARE + + F3 : A_T := NEW T; + + BEGIN + + F3.E; + + -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 . + + IF X /= 17 THEN + FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (5)" ); + END IF; + + END; + + END ; + + ------------------------------------------------------------------- + + + RESULT; + + +END C41306C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41307d.ada b/gcc/testsuite/ada/acats/tests/c4/c41307d.ada new file mode 100644 index 000000000..e65e79fb8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41307d.ada @@ -0,0 +1,255 @@ +-- C41307D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT L.R IS ALLOWED INSIDE A PACKAGE, GENERIC PACKAGE, +-- SUBPROGRAM, GENERIC SUBPROGRAM, TASK, BLOCK, LOOP, OR AN ACCEPT +-- STATEMENT NAMED L, IF R IS DECLARED INSIDE THE UNIT. + +-- TBN 12/15/86 + +WITH REPORT; USE REPORT; +PROCEDURE C41307D IS + +BEGIN + TEST ("C41307D", "CHECK THAT L.R IS ALLOWED INSIDE A PACKAGE, " & + "GENERIC PACKAGE, SUBPROGRAM, GENERIC " & + "SUBPROGRAM, TASK, BLOCK, LOOP, OR AN ACCEPT " & + "STATEMENT NAMED L, IF R IS DECLARED INSIDE " & + "THE UNIT"); + DECLARE + PACKAGE L IS + R : INTEGER := 5; + A : INTEGER := L.R; + END L; + + PACKAGE BODY L IS + B : INTEGER := L.R + 1; + BEGIN + IF IDENT_INT(A) /= 5 OR IDENT_INT(B) /= 6 THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + END L; + + GENERIC + S : INTEGER; + PACKAGE M IS + X : INTEGER := M.S; + END M; + + PACKAGE BODY M IS + Y : INTEGER := M.S + 1; + BEGIN + IF IDENT_INT(X) /= 2 OR + IDENT_INT(Y) /= 3 OR + IDENT_INT(M.X) /= 2 THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + END M; + + PACKAGE Q IS NEW M(2); + BEGIN + IF IDENT_INT(Q.X) /= 2 THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + END; + ------------------------------------------------------------------- + + DECLARE + CH : CHARACTER := '6'; + + PROCEDURE L (R : IN OUT CHARACTER) IS + A : CHARACTER := L.R; + BEGIN + IF IDENT_CHAR(L.A) /= '6' THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + L.R := IDENT_CHAR('7'); + END L; + + GENERIC + S : CHARACTER; + PROCEDURE M; + + PROCEDURE M IS + T : CHARACTER := M.S; + BEGIN + IF IDENT_CHAR(T) /= '3' OR IDENT_CHAR(M.S) /= '3' THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + END M; + + PROCEDURE P1 IS NEW M('3'); + + BEGIN + L (CH); + IF CH /= IDENT_CHAR('7') THEN + FAILED ("INCORRECT RESULTS RETURNED FROM PROCEDURE - 6"); + END IF; + P1; + END; + ------------------------------------------------------------------- + + DECLARE + INT : INTEGER := 3; + + FUNCTION L (R : INTEGER) RETURN INTEGER IS + A : INTEGER := L.R; + BEGIN + IF IDENT_INT(L.A) /= IDENT_INT(3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7"); + END IF; + RETURN IDENT_INT(4); + END L; + + GENERIC + S : INTEGER; + FUNCTION M RETURN INTEGER; + + FUNCTION M RETURN INTEGER IS + T : INTEGER := M.S; + BEGIN + IF IDENT_INT(M.T) /= 4 OR M.S /= IDENT_INT(4) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8"); + END IF; + RETURN IDENT_INT(1); + END M; + + FUNCTION F1 IS NEW M(4); + + BEGIN + IF L(INT) /= 4 OR F1 /= 1 THEN + FAILED ("INCORRECT RESULTS RETURNED FROM FUNCTION - 9"); + END IF; + END; + ------------------------------------------------------------------- + + DECLARE + TASK L IS + ENTRY E (A : INTEGER); + END L; + + TASK TYPE M IS + ENTRY E1 (A : INTEGER); + END M; + + T1 : M; + + TASK BODY L IS + X : INTEGER := IDENT_INT(1); + R : INTEGER RENAMES X; + Y : INTEGER := L.R; + BEGIN + X := X + L.R; + IF X /= IDENT_INT(2) OR Y /= IDENT_INT(1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - " & + "10"); + END IF; + END L; + + TASK BODY M IS + X : INTEGER := IDENT_INT(2); + R : INTEGER RENAMES X; + Y : INTEGER := M.R; + BEGIN + ACCEPT E1 (A : INTEGER) DO + X := X + M.R; + IF X /= IDENT_INT(4) OR Y /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED " & + "NAME - 11"); + END IF; + IF E1.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED " & + "NAME - 12"); + END IF; + END E1; + END M; + BEGIN + T1.E1 (3); + END; + ------------------------------------------------------------------- + + DECLARE + TASK T IS + ENTRY G (1..2) (A : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT G (1) (A : INTEGER) DO + IF G.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED " & + "NAME - 13"); + END IF; + BLK: + DECLARE + B : INTEGER := 7; + BEGIN + IF T.BLK.B /= IDENT_INT(7) THEN + FAILED ("INCORRECT RESULTS FROM " & + "EXPANDED NAME - 14"); + END IF; + END BLK; + END G; + ACCEPT G (2) (A : INTEGER) DO + IF G.A /= IDENT_INT(1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED " & + "NAME - 15"); + END IF; + END G; + END T; + BEGIN + T.G (1) (2); + T.G (2) (1); + END; + ------------------------------------------------------------------- + + SWAP: + DECLARE + VAR : CHARACTER := '*'; + RENAME_VAR : CHARACTER RENAMES VAR; + NEW_VAR : CHARACTER; + BEGIN + IF EQUAL (3, 3) THEN + NEW_VAR := SWAP.RENAME_VAR; + END IF; + IF NEW_VAR /= IDENT_CHAR('*') THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - " & + "16"); + END IF; + LP: FOR I IN 1..2 LOOP + IF SWAP.LP.I = IDENT_INT(2) OR + LP.I = IDENT_INT(1) THEN + GOTO SWAP.LAB1; + END IF; + NEW_VAR := IDENT_CHAR('+'); + <<LAB1>> + NEW_VAR := IDENT_CHAR('-'); + END LOOP LP; + IF NEW_VAR /= IDENT_CHAR('-') THEN + FAILED ("INCORRECT RESULTS FROM FOR LOOP - 17"); + END IF; + END SWAP; + + RESULT; +END C41307D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41309a.ada b/gcc/testsuite/ada/acats/tests/c4/c41309a.ada new file mode 100644 index 000000000..a1dc91734 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41309a.ada @@ -0,0 +1,69 @@ +-- C41309A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT AN EXPANDED NAME IS ALLOWED EVEN IF A USE CLAUSE MAKES THE +-- EXPANDED NAME UNNECESSARY. + +-- TBN 12/15/86 + +WITH REPORT; USE REPORT; +PROCEDURE C41309A IS + +BEGIN + TEST ("C41309A", "CHECK THAT AN EXPANDED NAME IS ALLOWED EVEN " & + "IF A USE CLAUSE MAKES THE EXPANDED NAME " & + "UNNECESSARY"); + DECLARE + PACKAGE P IS + PACKAGE Q IS + PACKAGE R IS + TYPE REC IS + RECORD + A : INTEGER := 5; + B : BOOLEAN := TRUE; + END RECORD; + REC1 : REC; + END R; + + USE R; + + REC2 : R.REC := R.REC1; + END Q; + + USE Q; USE R; + + REC3 : Q.R.REC := Q.REC2; + END P; + + USE P; USE Q; USE R; + + REC4 : P.Q.R.REC := P.REC3; + BEGIN + IF REC4 /= (IDENT_INT(5), IDENT_BOOL(TRUE)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME"); + END IF; + END; + + RESULT; +END C41309A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41320a.ada b/gcc/testsuite/ada/acats/tests/c4/c41320a.ada new file mode 100644 index 000000000..011174a62 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41320a.ada @@ -0,0 +1,97 @@ +-- C41320A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT IMPLICITLY DECLARED ENUMERATION LITERALS, CHARACTER +-- LITERALS, AND THE RELATIONAL OPERATORS CAN BE SELECTED FROM +-- OUTSIDE THE PACKAGE USING AN EXPANDED NAME, FOR ENUMERATION TYPES. + +-- HISTORY: +-- TBN 07/15/86 CREATED ORIGINAL TEST. +-- JET 08/04/87 ADDED TEST FOR OVERLOADED VARIABLES. + +WITH REPORT; USE REPORT; +PROCEDURE C41320A IS + + PACKAGE P IS + TYPE FLAG IS (RED, WHITE, BLUE); + TYPE ROMAN_DIGITS IS ('I', 'V', 'X', 'C', 'M'); + TYPE TRAFFIC_LIGHT IS (RED, YELLOW, GREEN); + TYPE HEX IS ('A', 'B', 'C', 'D', 'E', 'F'); + FLAG_COLOR_1 : FLAG := RED; + FLAG_COLOR_2 : FLAG := WHITE; + TRAFFIC_LIGHT_COLOR_1 : FLAG := RED; + HEX_3 : HEX := 'C'; + ROMAN_1 : ROMAN_DIGITS := 'I'; + END P; + + USA_FLAG_1 : P.FLAG := P.RED; + USA_FLAG_3 : P.FLAG := P.BLUE; + HEX_CHAR_3 : P.HEX := P.'C'; + ROMAN_DIGITS_4 : P.ROMAN_DIGITS := P.'C'; + TRAFFIC_LIGHT_1 : P.TRAFFIC_LIGHT := P.RED; + +BEGIN + TEST ("C41320A", "CHECK THAT IMPLICITLY DECLARED ENUMERATION " & + "LITERALS, CHARACTER LITERALS, AND THE " & + "RELATIONAL OPERATORS CAN BE SELECTED FROM " & + "OUTSIDE THE PACKAGE USING AN EXPANDED NAME " & + "FOR ENUMERATION TYPES"); + + IF P."/=" (USA_FLAG_1, P.FLAG_COLOR_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."=" (USA_FLAG_3, P.FLAG_COLOR_2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."<" (HEX_CHAR_3, P.HEX_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + IF P.">" (P.ROMAN_1, ROMAN_DIGITS_4) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + IF P.">=" (TRAFFIC_LIGHT_1, P.TRAFFIC_LIGHT'PRED (P.GREEN)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + + FOR J IN P.FLAG'(P.WHITE) .. P.FLAG'(P.WHITE) LOOP + IF P."<=" (P.FLAG'SUCC (P.WHITE), J) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6"); + END IF; + END LOOP; + + IF P.">=" (P.RED, P.GREEN) THEN + FAILED ("INCORRECT RESULT FROM OVERLOADED VARIABLE NAME - 1"); + END IF; + + IF P."<=" (P.BLUE, P.RED) THEN + FAILED ("INCORRECT RESULT FROM OVERLOADED VARIABLE NAME - 2"); + END IF; + + RESULT; +END C41320A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41321a.ada b/gcc/testsuite/ada/acats/tests/c4/c41321a.ada new file mode 100644 index 000000000..8064c127b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41321a.ada @@ -0,0 +1,106 @@ +-- C41321A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IMPLICITLY DECLARED RELATIONAL OPERATORS, LOGICAL +-- OPERATORS, AND THE "NOT" OPERATOR MAY BE SELECTED FROM OUTSIDE +-- THE PACKAGE USING AN EXPANDED NAME, FOR A DERIVED BOOLEAN TYPE. + +-- TBN 7/16/86 + +WITH REPORT; USE REPORT; +PROCEDURE C41321A IS + + PACKAGE P IS + TYPE DERIVED_BOOLEAN IS NEW BOOLEAN RANGE FALSE .. TRUE; + DERIVED_FALSE : DERIVED_BOOLEAN := FALSE; + DERIVED_TRUE : DERIVED_BOOLEAN := TRUE; + END P; + + DBOOL_FALSE : P.DERIVED_BOOLEAN := P.FALSE; + DBOOL_TRUE : P.DERIVED_BOOLEAN := P.TRUE; + +BEGIN + TEST ("C41321A", "CHECK THAT IMPLICITLY DECLARED RELATIONAL " & + "OPERATORS, LOGICAL OPERATORS, AND THE 'NOT' " & + "OPERATOR MAY BE SELECTED FROM OUTSIDE THE " & + "PACKAGE USING AN EXPANDED NAME, FOR A DERIVED " & + "BOOLEAN TYPE"); + + IF P."=" (DBOOL_FALSE, P.DERIVED_TRUE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."/=" (DBOOL_TRUE, P.DERIVED_TRUE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."<" (P.DERIVED_TRUE, P.DERIVED_FALSE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + IF P.">" (DBOOL_TRUE, P.DERIVED_TRUE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + IF P."<=" (P.DERIVED_TRUE, DBOOL_FALSE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + + IF P."<=" (P.DERIVED_TRUE, DBOOL_TRUE) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6"); + END IF; + + IF P.">=" (P.DERIVED_TRUE, DBOOL_TRUE) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7"); + END IF; + + FOR J IN P.DERIVED_BOOLEAN'(P.TRUE) .. P.DERIVED_BOOLEAN'(P.TRUE) + LOOP + IF P.">=" (DBOOL_FALSE, J) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8"); + END IF; + END LOOP; + + IF P."AND" (DBOOL_FALSE, P.DERIVED_TRUE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9"); + END IF; + + IF P."OR" (DBOOL_FALSE, P.DERIVED_FALSE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10"); + END IF; + + IF P."XOR" (DBOOL_TRUE, P.DERIVED_TRUE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11"); + END IF; + + IF P."NOT" (P.DERIVED_TRUE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12"); + END IF; + + RESULT; +END C41321A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41322a.ada b/gcc/testsuite/ada/acats/tests/c4/c41322a.ada new file mode 100644 index 000000000..eaf3a6ff7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41322a.ada @@ -0,0 +1,125 @@ +-- C41322A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IMPLICITLY DECLARED RELATIONAL OPERATORS AND ARITHMETIC +-- OPERATORS (+, -, *, /, **, ABS, MOD, REM) MAY BE SELECTED FROM +-- OUTSIDE THE PACKAGE USING AN EXPANDED NAME, FOR AN INTEGER TYPE. + +-- TBN 7/16/86 + +WITH REPORT; USE REPORT; +PROCEDURE C41322A IS + + PACKAGE P IS + TYPE INT IS RANGE -10 .. 10; + OBJ_INT_1 : INT := -10; + OBJ_INT_2 : INT := 1; + OBJ_INT_3 : INT := 10; + END P; + + INT_VAR : P.INT; + INT_VAR_1 : P.INT := P."-"(P.INT'(10)); + INT_VAR_2 : P.INT := P.INT'(1); + INT_VAR_3 : P.INT := P.INT'(10); + +BEGIN + TEST ("C41322A", "CHECK THAT IMPLICITLY DECLARED RELATIONAL " & + "OPERATORS AND ARITHMETIC OPERATORS (+, -, *, " & + "/, **, ABS, MOD, REM) MAY BE SELECTED FROM " & + "OUTSIDE THE PACKAGE USING AN EXPANDED NAME, " & + "FOR AN INTEGER TYPE"); + + IF P."=" (INT_VAR_1, P.INT'(2)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."/=" (INT_VAR_1, P.OBJ_INT_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."<" (INT_VAR_2, 0) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + IF P.">" (INT_VAR_2, P.OBJ_INT_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + IF P."<=" (INT_VAR_3, P.INT'(9)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + + FOR J IN P.INT'(4) .. P.INT'(4) LOOP + IF P.">=" (J, INT_VAR_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6"); + END IF; + END LOOP; + + INT_VAR := P."+" (INT_VAR_1, P.INT'(2)); + IF P."/=" (INT_VAR, P."-"(P.INT'(8))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7"); + END IF; + + INT_VAR := P."+" (P.INT'(2)); + IF P."/=" (INT_VAR, P.INT'(2)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8"); + END IF; + + INT_VAR := P."-" (INT_VAR_2, P.INT'(0)); + IF P."/=" (INT_VAR, P.OBJ_INT_2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9"); + END IF; + + INT_VAR := P."*" (INT_VAR_2, P.INT'(5)); + IF P."/=" (INT_VAR, P.INT'(5)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10"); + END IF; + + INT_VAR := P."/" (INT_VAR_3, P.INT'(2)); + IF P."/=" (INT_VAR, P.INT'(5)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11"); + END IF; + + INT_VAR := P."**" (P.INT'(2), 3); + IF P."/=" (INT_VAR, P.INT'(8)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12"); + END IF; + + INT_VAR := P."ABS" (INT_VAR_1); + IF P."/=" (INT_VAR, P.OBJ_INT_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 13"); + END IF; + + INT_VAR := P."MOD" (INT_VAR_1, P.INT'(3)); + IF P."/=" (INT_VAR, P.INT'(2)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 14"); + END IF; + + INT_VAR := P."REM" (INT_VAR_1, P.INT'(3)); + IF P."/=" (INT_VAR, P."-" (INT_VAR_2)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 15"); + END IF; + + RESULT; +END C41322A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41323a.ada b/gcc/testsuite/ada/acats/tests/c4/c41323a.ada new file mode 100644 index 000000000..f82a97abf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41323a.ada @@ -0,0 +1,125 @@ +-- C41323A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IMPLICITLY DECLARED RELATIONAL OPERATORS AND ARITHMETIC +-- OPERATORS (+, -, *, /, **, ABS) MAY BE SELECTED FROM OUTSIDE THE +-- PACKAGE USING AN EXPANDED NAME, FOR A FLOATING POINT TYPE. + +-- TBN 7/16/86 + +WITH REPORT; USE REPORT; +PROCEDURE C41323A IS + + PACKAGE P IS + TYPE FLOAT IS DIGITS 5 RANGE -1.0E1 .. 1.0E1; + OBJ_FLO_1 : FLOAT := -5.5; + OBJ_FLO_2 : FLOAT := 1.5; + OBJ_FLO_3 : FLOAT := 10.0; + END P; + + FLO_VAR : P.FLOAT; + FLO_VAR_1 : P.FLOAT := P."-"(P.FLOAT'(5.5)); + FLO_VAR_2 : P.FLOAT := P.FLOAT'(1.5); + FLO_VAR_3 : P.FLOAT := P.FLOAT'(1.0E1); + +BEGIN + TEST ("C41323A", "CHECK THAT IMPLICITLY DECLARED RELATIONAL " & + "OPERATORS AND ARITHMETIC OPERATORS (+, -, *, " & + "/, **, ABS) MAY BE SELECTED FROM OUTSIDE THE " & + "PACKAGE USING AN EXPANDED NAME, FOR A " & + "FLOATING POINT TYPE"); + + IF P."=" (FLO_VAR_1, P."-"(P.FLOAT'(5.55))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."/=" (FLO_VAR_1, P.OBJ_FLO_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."<" (FLO_VAR_2, P.OBJ_FLO_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + IF P.">" (FLO_VAR_2, P.OBJ_FLO_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + IF P."<=" (FLO_VAR_3, P.FLOAT'(9.9)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + + IF P."<=" (FLO_VAR_3, P.FLOAT'(10.0)) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6"); + END IF; + + IF P.">=" (P.OBJ_FLO_2, FLO_VAR_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7"); + END IF; + + IF P.">=" (P.OBJ_FLO_3, FLO_VAR_3) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8"); + END IF; + + FLO_VAR := P."+" (FLO_VAR_1, P.OBJ_FLO_2); + IF P."/=" (FLO_VAR, P."-"(P.FLOAT'(4.0))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9"); + END IF; + + FLO_VAR := P."+" (FLO_VAR_1); + IF P."/=" (FLO_VAR, P.OBJ_FLO_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10"); + END IF; + + FLO_VAR := P."-" (FLO_VAR_2, P.OBJ_FLO_1); + IF P."/=" (FLO_VAR, P.FLOAT'(7.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11"); + END IF; + + FLO_VAR := P."*" (FLO_VAR_2, P.FLOAT'(2.0)); + IF P."/=" (FLO_VAR, P.FLOAT'(3.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12"); + END IF; + + FLO_VAR := P."/" (FLO_VAR_3, P.FLOAT'(2.0)); + IF P."/=" (FLO_VAR, P.FLOAT'(5.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 13"); + END IF; + + FLO_VAR := P."**" (P.FLOAT'(2.0), 3); + IF P."/=" (FLO_VAR, P.FLOAT'(8.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 14"); + END IF; + + FLO_VAR := P."ABS" (FLO_VAR_1); + IF P."/=" (FLO_VAR, P.FLOAT'(5.5)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 15"); + END IF; + + RESULT; +END C41323A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41324a.ada b/gcc/testsuite/ada/acats/tests/c4/c41324a.ada new file mode 100644 index 000000000..19992a29b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41324a.ada @@ -0,0 +1,120 @@ +-- C41324A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IMPLICITLY DECLARED RELATIONAL OPERATORS AND ARITHMETIC +-- OPERATORS (+, -, *, /, ABS) MAY BE SELECTED FROM OUTSIDE THE +-- PACKAGE USING AN EXPANDED NAME, FOR A FIXED POINT TYPE. + +-- TBN 7/16/86 + +WITH REPORT; USE REPORT; +PROCEDURE C41324A IS + + PACKAGE P IS + TYPE FIXED IS DELTA 0.125 RANGE -1.0E1 .. 1.0E1; + OBJ_FIX_1 : FIXED := -5.5; + OBJ_FIX_2 : FIXED := 1.5; + OBJ_FIX_3 : FIXED := 10.0; + END P; + + FIX_VAR : P.FIXED; + FIX_VAR_1 : P.FIXED := P."-"(P.FIXED'(5.5)); + FIX_VAR_2 : P.FIXED := P.FIXED'(1.5); + FIX_VAR_3 : P.FIXED := P.FIXED'(1.0E1); + +BEGIN + TEST ("C41324A", "CHECK THAT IMPLICITLY DECLARED RELATIONAL " & + "OPERATORS AND ARITHMETIC OPERATORS (+, -, *, " & + "/, ABS) MAY BE SELECTED FROM OUTSIDE THE " & + "PACKAGE USING AN EXPANDED NAME, FOR A FIXED " & + "POINT TYPE"); + + IF P."=" (FIX_VAR_1, P."-"(P.FIXED'(6.0))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."/=" (FIX_VAR_1, P.OBJ_FIX_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."<" (FIX_VAR_2, P.OBJ_FIX_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + IF P.">" (FIX_VAR_2, P.OBJ_FIX_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + IF P."<=" (FIX_VAR_3, P.FIXED'(9.9)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + + IF P."<=" (FIX_VAR_3, P.FIXED'(10.0)) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6"); + END IF; + + IF P.">=" (P.OBJ_FIX_2, FIX_VAR_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7"); + END IF; + + IF P.">=" (P.OBJ_FIX_2, FIX_VAR_2) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8"); + END IF; + + FIX_VAR := P."+" (FIX_VAR_1, P.OBJ_FIX_2); + IF P."/=" (FIX_VAR, P."-"(P.FIXED'(4.0))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9"); + END IF; + + FIX_VAR := P."-" (FIX_VAR_2, P.OBJ_FIX_1); + IF P."/=" (FIX_VAR, P.FIXED'(7.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10"); + END IF; + + FIX_VAR := P."*" (FIX_VAR_2, 2); + IF P."/=" (FIX_VAR, P.FIXED'(3.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11"); + END IF; + + FIX_VAR := P."*" (3, FIX_VAR_2); + IF P."/=" (FIX_VAR, P.FIXED'(4.5)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12"); + END IF; + + FIX_VAR := P."/" (FIX_VAR_3, 2); + IF P."/=" (FIX_VAR, P.FIXED'(5.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 13"); + END IF; + + FIX_VAR := P."ABS" (FIX_VAR_1); + IF P."/=" (FIX_VAR, P.FIXED'(5.5)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 14"); + END IF; + + RESULT; +END C41324A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41325a.ada b/gcc/testsuite/ada/acats/tests/c4/c41325a.ada new file mode 100644 index 000000000..95437ab3e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41325a.ada @@ -0,0 +1,173 @@ +-- C41325A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE FOLLOWING IMPLICITLY DECLARED ENTITIES CAN BE SELECTED +-- FROM OUTSIDE THE PACKAGE USING AN EXPANDED NAME, FOR AN ARRAY TYPE. +-- CASE 1: CHECK EQUALITY AND INEQUALITY WHEN COMPONENT TYPE IS +-- NON-LIMITED, FOR MULTIDIMENSIONAL ARRAYS. +-- CASE 2: FOR ONE DIMENSIONAL ARRAYS: +-- A) CHECK CATENATION, EQUALITY, AND INEQUALITY WHEN +-- COMPONENT TYPE IS NON-LIMITED. +-- B) CHECK RELATIONAL OPERATORS WHEN COMPONENT TYPE IS +-- DISCRETE. +-- C) CHECK THE "NOT" OPERATOR AND THE LOGICAL OPERATORS +-- WHEN COMPONENT TYPE IS BOOLEAN. + +-- TBN 7/17/86 + +WITH REPORT; USE REPORT; +PROCEDURE C41325A IS + + PACKAGE P IS + TYPE CATARRAY IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE ARRAY_1 IS ARRAY (1..10) OF INTEGER; + TYPE ARRAY_2 IS ARRAY (1..4, 1..4) OF INTEGER; + TYPE ARRAY_3 IS ARRAY (1..2, 1..3, 1..4) OF INTEGER; + TYPE ARRAY_4 IS ARRAY (1..10) OF BOOLEAN; + TYPE ARRAY_5 IS ARRAY (1..4, 1..4) OF BOOLEAN; + TYPE ARRAY_6 IS ARRAY (1..2, 1..3, 1..4) OF BOOLEAN; + + OBJ_ARA_1 : ARRAY_1 := (1..10 => IDENT_INT(0)); + OBJ_ARA_2 : ARRAY_2 := (1..4 => (1..4 => IDENT_INT(0))); + OBJ_ARA_3 : ARRAY_3 := (1..2 => (1..3 => + (1..4 => IDENT_INT(0)))); + OBJ_ARA_4 : ARRAY_4 := (1..10 => IDENT_BOOL(FALSE)); + OBJ_ARA_5 : ARRAY_5 := (1..4 => (1..4 => IDENT_BOOL(FALSE))); + OBJ_ARA_6 : ARRAY_6 := (1..2 => (1..3 => + (1..4 => IDENT_BOOL(FALSE)))); + OBJ_ARA_7 : CATARRAY (1..10) := (1..10 => IDENT_INT(0)); + OBJ_ARA_20 : CATARRAY (1..20) := (1..10 => 1, + 11..20 => IDENT_INT(0)); + END P; + + VAR_ARA_1 : P.ARRAY_1 := (1..10 => IDENT_INT(1)); + VAR_ARA_2 : P.ARRAY_2 := (1..4 => (1..4 => IDENT_INT(1))); + VAR_ARA_3 : P.ARRAY_3 := (1..2 => (1..3 => + (1..4 => IDENT_INT(1)))); + VAR_ARA_4 : P.ARRAY_4 := (1..10 => IDENT_BOOL(TRUE)); + VAR_ARA_5 : P.ARRAY_5 := (1..4 => (1..4 => IDENT_BOOL(TRUE))); + VAR_ARA_6 : P.ARRAY_6 := (1..2 => (1..3 => + (1..4 => IDENT_BOOL(TRUE)))); + VAR_ARA_7 : P.CATARRAY (1..10) := (1..10 => IDENT_INT(1)); + VAR_ARA_8 : P.ARRAY_4 := (1..10 => IDENT_BOOL(TRUE)); + VAR_ARA_20 : P.CATARRAY (1..20) := (1..20 => IDENT_INT(0)); + +BEGIN + TEST ("C41325A", "CHECK THAT IMPLICITLY DECLARED ENTITIES CAN " & + "BE SELECTED FROM OUTSIDE THE PACKAGE USING AN " & + "EXPANDED NAME, FOR AN ARRAY TYPE"); + + -- CASE 1: MULTIDIMENSIONAL ARRAYS. + + IF P."=" (VAR_ARA_2, P.OBJ_ARA_2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."=" (VAR_ARA_5, P.OBJ_ARA_5) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."/=" (VAR_ARA_2, P.ARRAY_2'(1..4 => (1..4 => 1))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + IF P."/=" (VAR_ARA_5, P.ARRAY_5'(1..4 => (1..4 => TRUE))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + IF P."=" (VAR_ARA_3, P.OBJ_ARA_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + + IF P."/=" (VAR_ARA_6, P.ARRAY_6'(1..2 =>(1..3 =>(1..4 => TRUE)))) + THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6"); + END IF; + + -- CASE 2: ONE DIMENSIONAL ARRAYS. + + IF P."=" (VAR_ARA_1, P.OBJ_ARA_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7"); + END IF; + + IF P."/=" (VAR_ARA_1, P.ARRAY_1'(1..10 => 1)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8"); + END IF; + + VAR_ARA_20 := P."&" (VAR_ARA_7, P.OBJ_ARA_7); + IF P."/=" (VAR_ARA_20, P.OBJ_ARA_20) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9"); + END IF; + + IF P."<" (VAR_ARA_1, P.OBJ_ARA_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10"); + END IF; + + IF P.">" (P.OBJ_ARA_1, VAR_ARA_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11"); + END IF; + + IF P."<=" (VAR_ARA_1, P.OBJ_ARA_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12"); + END IF; + + IF P."<=" (VAR_ARA_1, P.ARRAY_1'(1..10 => 1)) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 13"); + END IF; + + IF P.">=" (VAR_ARA_1, P.ARRAY_1'(1..10 => 2)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 14"); + END IF; + + IF P.">=" (VAR_ARA_1, P.ARRAY_1'(1..10 => 1)) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 15"); + END IF; + + VAR_ARA_8 := P."NOT" (VAR_ARA_4); + IF P."/=" (VAR_ARA_8, P.OBJ_ARA_4) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 16"); + END IF; + + VAR_ARA_8 := P."OR" (VAR_ARA_4, P.OBJ_ARA_4); + IF P."=" (VAR_ARA_8, P.OBJ_ARA_4) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 17"); + END IF; + + VAR_ARA_8 := P."AND" (VAR_ARA_4, P.OBJ_ARA_4); + IF P."/=" (VAR_ARA_8, P.OBJ_ARA_4) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 18"); + END IF; + + VAR_ARA_8 := P."XOR" (VAR_ARA_4, P.OBJ_ARA_4); + IF P."=" (VAR_ARA_8, P.OBJ_ARA_4) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 19"); + END IF; + + RESULT; +END C41325A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41326a.ada b/gcc/testsuite/ada/acats/tests/c4/c41326a.ada new file mode 100644 index 000000000..9ef3c65b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41326a.ada @@ -0,0 +1,72 @@ +-- C41326A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IMPLICITLY DECLARED EQUALITY AND INEQUALITY OPERATORS +-- MAY BE SELECTED FROM OUTSIDE A PACKAGE USING AN EXPANDED NAME, FOR +-- AN ACCESS TYPE. + +-- TBN 7/18/86 + +WITH REPORT; USE REPORT; +PROCEDURE C41326A IS + + PACKAGE P IS + TYPE CELL IS + RECORD + VALUE : INTEGER; + END RECORD; + TYPE LINK IS ACCESS CELL; + + OBJ_LINK_1 : LINK := NEW CELL'(VALUE => 1); + OBJ_LINK_2 : LINK := OBJ_LINK_1; + END P; + + VAR_LINK_1 : P.LINK := NEW P.CELL'(VALUE => 1); + VAR_LINK_2 : P.LINK := NEW P.CELL'(VALUE => 2); + +BEGIN + TEST ("C41326A", "CHECK THAT IMPLICITLY DECLARED EQUALITY AND " & + "INEQUALITY OPERATORS MAY BE SELECTED FROM " & + "OUTSIDE A PACKAGE USING AN EXPANDED NAME, " & + "FOR AN ACCESS TYPE"); + + IF P."=" (VAR_LINK_1, P.OBJ_LINK_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."/=" (P.OBJ_LINK_1, P.OBJ_LINK_2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."=" (VAR_LINK_2.ALL, P.OBJ_LINK_1.ALL) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + VAR_LINK_2.VALUE := 1; + IF P."/=" (VAR_LINK_2.ALL, P.OBJ_LINK_1.ALL) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + RESULT; +END C41326A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41327a.ada b/gcc/testsuite/ada/acats/tests/c4/c41327a.ada new file mode 100644 index 000000000..4d5d85284 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41327a.ada @@ -0,0 +1,84 @@ +-- C41327A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IMPLICITLY DECLARED EQUALITY AND INEQUALITY OPERATORS +-- MAY BE SELECTED FROM OUTSIDE A PACKAGE USING AN EXPANDED NAME, FOR +-- A PRIVATE TYPE. + +-- TBN 7/18/86 + +WITH REPORT; USE REPORT; +PROCEDURE C41327A IS + + PACKAGE P IS + TYPE KEY IS PRIVATE; + TYPE CHAR IS PRIVATE; + FUNCTION INIT_KEY (X : NATURAL) RETURN KEY; + FUNCTION INIT_CHAR (X : CHARACTER) RETURN CHAR; + PRIVATE + TYPE KEY IS NEW NATURAL; + TYPE CHAR IS NEW CHARACTER; + END P; + + VAR_KEY_1 : P.KEY; + VAR_KEY_2 : P.KEY; + VAR_CHAR_1 : P.CHAR; + VAR_CHAR_2 : P.CHAR; + + PACKAGE BODY P IS + + FUNCTION INIT_KEY (X : NATURAL) RETURN KEY IS + BEGIN + RETURN (KEY (X)); + END INIT_KEY; + + FUNCTION INIT_CHAR (X : CHARACTER) RETURN CHAR IS + BEGIN + RETURN (CHAR (X)); + END INIT_CHAR; + + BEGIN + NULL; + END P; + +BEGIN + TEST ("C41327A", "CHECK THAT IMPLICITLY DECLARED EQUALITY AND " & + "INEQUALITY OPERATORS MAY BE SELECTED FROM " & + "OUTSIDE A PACKAGE USING AN EXPANDED NAME, " & + "FOR A PRIVATE TYPE"); + + VAR_KEY_1 := P.INIT_KEY (1); + VAR_KEY_2 := P.INIT_KEY (2); + VAR_CHAR_1 := P.INIT_CHAR ('A'); + VAR_CHAR_2 := P.INIT_CHAR ('A'); + IF P."=" (VAR_KEY_1, VAR_KEY_2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."/=" (VAR_CHAR_1, VAR_CHAR_2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + RESULT; +END C41327A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41328a.ada b/gcc/testsuite/ada/acats/tests/c4/c41328a.ada new file mode 100644 index 000000000..3c6ea5b2f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41328a.ada @@ -0,0 +1,100 @@ +-- C41328A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IMPLICITLY DECLARED DERIVED SUBPROGRAMS CAN BE SELECTED +-- FROM OUTSIDE A PACKAGE USING AN EXPANDED NAME, FOR A DERIVED TYPE. + +-- TBN 7/21/86 + +WITH REPORT; USE REPORT; +PROCEDURE C41328A IS + + PACKAGE P IS + PACKAGE Q IS + TYPE PAIR IS ARRAY (1..2) OF INTEGER; + FUNCTION INIT (INT : INTEGER) RETURN PAIR; + PROCEDURE SWAP (TWO : IN OUT PAIR); + END Q; + TYPE COUPLE IS NEW Q.PAIR; + END P; + + VAR_1 : P.COUPLE; + VAR_2 : P.COUPLE; + + PACKAGE BODY P IS + + PACKAGE BODY Q IS + + FUNCTION INIT (INT : INTEGER) RETURN PAIR IS + A : PAIR; + BEGIN + A (1) := INT; + A (2) := INT + 1; + RETURN (A); + END INIT; + + PROCEDURE SWAP (TWO : IN OUT PAIR) IS + TEMP : INTEGER; + BEGIN + TEMP := TWO (1); + TWO (1) := TWO (2); + TWO (2) := TEMP; + END SWAP; + + BEGIN + NULL; + END Q; + + BEGIN + NULL; + END P; + +BEGIN + TEST ("C41328A", "CHECK THAT IMPLICITLY DECLARED DERIVED " & + "SUBPROGRAMS CAN BE SELECTED FROM OUTSIDE A " & + "PACKAGE USING AN EXPANDED NAME, FOR A DERIVED " & + "TYPE"); + + VAR_1 := P.INIT (IDENT_INT(1)); + IF P."/=" (VAR_1, P.COUPLE'(1 => 1, 2 => 2)) THEN + FAILED ("INCORRECT RESULTS FROM DERIVED SUBPROGRAM - 1"); + END IF; + + VAR_2 := P.INIT (IDENT_INT(2)); + IF P."=" (VAR_2, P.COUPLE'(1 => 1, 2 => 2)) THEN + FAILED ("INCORRECT RESULTS FROM DERIVED SUBPROGRAM - 2"); + END IF; + + P.SWAP (VAR_1); + IF P."=" (VAR_1, P.COUPLE'(1 => 1, 2 => 2)) THEN + FAILED ("INCORRECT RESULTS FROM DERIVED SUBPROGRAM - 3"); + END IF; + + P.SWAP (VAR_2); + IF P."/=" (VAR_2, P.COUPLE'(1 => 3, 2 => 2)) THEN + FAILED ("INCORRECT RESULTS FROM DERIVED SUBPROGRAM - 4"); + END IF; + + RESULT; +END C41328A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41401a.ada b/gcc/testsuite/ada/acats/tests/c4/c41401a.ada new file mode 100644 index 000000000..f58a8a472 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41401a.ada @@ -0,0 +1,216 @@ +-- C41401A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE PREFIX OF THE FOLLOWING +-- ATTRIBUTES HAS THE VALUE NULL: +-- A) 'CALLABLE AND 'TERMINATED FOR A TASK TYPE. +-- B) 'FIRST, 'FIRST(N), 'LAST, 'LAST(N), 'LENGTH, 'LENGTH(N), +-- 'RANGE, AND 'RANGE(N) FOR AN ARRAY TYPE. + +-- TBN 10/2/86 +-- EDS 07/14/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C41401A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 10; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE ACC_TT IS ACCESS TT; + + TYPE NULL_ARR1 IS ARRAY (2 .. 1) OF INTEGER; + TYPE ARRAY1 IS ARRAY (INT RANGE <>) OF INTEGER; + TYPE NULL_ARR2 IS ARRAY (3 .. 1, 2 .. 1) OF INTEGER; + TYPE ARRAY2 IS ARRAY (INT RANGE <>, INT RANGE <>) OF INTEGER; + TYPE ACC_NULL1 IS ACCESS NULL_ARR1; + TYPE ACC_ARR1 IS ACCESS ARRAY1; + TYPE ACC_NULL2 IS ACCESS NULL_ARR2; + TYPE ACC_ARR2 IS ACCESS ARRAY2; + + PTR_TT : ACC_TT; + PTR_ARA1: ACC_NULL1; + PTR_ARA2 : ACC_ARR1 (1 .. 4); + PTR_ARA3 : ACC_NULL2; + PTR_ARA4 : ACC_ARR2 (1 .. 2, 2 .. 4); + BOOL_VAR : BOOLEAN := FALSE; + INT_VAR : INTEGER := 1; + + TASK BODY TT IS + BEGIN + ACCEPT E; + END TT; + +BEGIN + TEST ("C41401A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE " & + "PREFIX HAS A VALUE OF NULL FOR THE FOLLOWING " & + "ATTRIBUTES: 'CALLABLE, 'TERMINATED, 'FIRST, " & + "'LAST, 'LENGTH, AND 'RANGE"); + + BEGIN + IF EQUAL (3, 2) THEN + PTR_TT := NEW TT; + END IF; + BOOL_VAR := IDENT_BOOL(PTR_TT'CALLABLE); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1 " & BOOLEAN'IMAGE(BOOL_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + BEGIN + IF EQUAL (1, 3) THEN + PTR_TT := NEW TT; + END IF; + BOOL_VAR := IDENT_BOOL(PTR_TT'TERMINATED); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 3 " & BOOLEAN'IMAGE(BOOL_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA1'FIRST); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 5 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA2'LAST); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 7 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 8"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA1'LENGTH); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 9 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 10"); + END; + + BEGIN + DECLARE + A : ARRAY1 (PTR_ARA2'RANGE); + BEGIN + A (1) := IDENT_INT(1); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 11 " & + INTEGER'IMAGE(A(1))); + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT_ERROR NOT RAISED - 11 "); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 12"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA3'FIRST(2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 13 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 14"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA4'LAST(2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 15 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 16"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA3'LENGTH(2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 17 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 18"); + END; + + BEGIN + DECLARE + A : ARRAY1 (PTR_ARA4'RANGE(2)); + BEGIN + A (1) := IDENT_INT(1); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 19 " & + INTEGER'IMAGE(A(1))); + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT_ERROR NOT RAISED - 19 "); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 20"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA4'LAST(1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 21 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 22"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA3'LENGTH(1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 23 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 24"); + END; + + RESULT; +END C41401A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41402a.ada b/gcc/testsuite/ada/acats/tests/c4/c41402a.ada new file mode 100644 index 000000000..003fb12eb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41402a.ada @@ -0,0 +1,118 @@ +-- C41402A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF THE PREFIX OF +-- 'ADDRESS, 'SIZE, 'FIRST_BIT, 'LAST_BIT, AND 'POSITION HAS THE +-- VALUE NULL. + +-- HISTORY: +-- TBN 10/02/86 CREATED ORIGINAL TEST. +-- CJJ 07/01/87 REMOVED TEST FOR 'STORAGE_SIZE, WHICH IS NO LONGER +-- PART OF THE OBJECTIVE. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C41402A IS + + TYPE ARRAY1 IS ARRAY (1 .. 2) OF INTEGER; + TYPE ACC_ARA IS ACCESS ARRAY1; + + PTR_ARA : ACC_ARA; + VAR1 : INTEGER; + + TYPE REC1 IS + RECORD + A : INTEGER; + END RECORD; + + TYPE ACC_REC1 IS ACCESS REC1; + + TYPE REC2 IS + RECORD + P_AR : ACC_ARA; + P_REC : ACC_REC1; + END RECORD; + + OBJ_REC : REC2; + + + PROCEDURE PROC (A : ADDRESS) IS + BEGIN + NULL; + END; + +BEGIN + TEST ("C41402A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "THE PREFIX OF 'ADDRESS, 'SIZE, " & + "'FIRST_BIT, 'LAST_BIT, AND 'POSITION HAS THE " & + "VALUE NULL"); + + BEGIN + PROC (PTR_ARA'ADDRESS); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR 'ADDRESS"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED 'ADDRESS"); + END; + + BEGIN + VAR1 := PTR_ARA'SIZE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR 'SIZE"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED 'SIZE"); + END; + + BEGIN + VAR1 := OBJ_REC.P_AR'FIRST_BIT; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR 'FIRST_BIT"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED 'FIRST_BIT"); + END; + + BEGIN + VAR1 := OBJ_REC.P_AR'LAST_BIT; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR 'LAST_BIT"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED 'LAST_BIT"); + END; + + BEGIN + VAR1 := OBJ_REC.P_REC'POSITION; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR 'POSITION"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED 'POSITION"); + END; + + RESULT; +END C41402A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c41404a.ada b/gcc/testsuite/ada/acats/tests/c4/c41404a.ada new file mode 100644 index 000000000..9aa937852 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41404a.ada @@ -0,0 +1,136 @@ +-- C41404A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE PREFIX OF THE ARRAY ATTRIBUTES CAN BE THE VALUE OF AN +-- IMAGE ATTRIBUTE. + +-- JBG 6/1/85 +-- PWB 2/3/86 CORRECTED COMPARISON VALUES FOR 'LAST AND 'LENGTH. + +WITH REPORT; USE REPORT; +PROCEDURE C41404A IS + + TYPE ENUM IS (ONE, FOUR, 'C'); + +BEGIN + + TEST ("C41404A", "CHECK WHEN PREFIX OF AN ATTRIBUTE IS 'IMAGE"); + + IF ENUM'IMAGE(FOUR)'LENGTH /= IDENT_INT(4) THEN + FAILED ("WRONG VALUE FOR LENGTH - ENUM"); + END IF; + + IF ENUM'IMAGE('C')'LENGTH /= IDENT_INT(3) THEN + FAILED ("WRONG VALUE FOR LENGTH - ENUM: 'C'"); + END IF; + + IF INTEGER'IMAGE(IDENT_INT(56))'LENGTH /= IDENT_INT(3) THEN + FAILED ("WRONG VALUE FOR LENGTH - INTEGER: 56"); + END IF; + + IF CHARACTER'IMAGE(IDENT_CHAR('B'))'LENGTH /= IDENT_INT(3) THEN + FAILED ("WRONG VALUE FOR LENGTH - CHAR: 'B'"); + END IF; + + IF ENUM'IMAGE(FOUR)'FIRST /= IDENT_INT(1) THEN + FAILED ("WRONG VALUE FOR FIRST - ENUM"); + END IF; + + IF ENUM'IMAGE('C')'FIRST(1) /= IDENT_INT(1) THEN + FAILED ("WRONG VALUE FOR FIRST - ENUM: 'C'"); + END IF; + + IF INTEGER'IMAGE(IDENT_INT(56))'FIRST /= IDENT_INT(1) THEN + FAILED ("WRONG VALUE FOR FIRST - INTEGER: 56"); + END IF; + + IF CHARACTER'IMAGE(IDENT_CHAR('B'))'FIRST /= IDENT_INT(1) THEN + FAILED ("WRONG VALUE FOR FIRST - CHAR: 'B'"); + END IF; + + IF ENUM'IMAGE(FOUR)'LAST /= IDENT_INT(4) THEN + FAILED ("WRONG VALUE FOR LAST - ENUM"); + END IF; + + IF ENUM'IMAGE('C')'LAST(1) /= IDENT_INT(3) THEN + FAILED ("WRONG VALUE FOR LAST - ENUM: 'C'"); + END IF; + + IF INTEGER'IMAGE(IDENT_INT(-56))'LAST /= IDENT_INT(3) THEN + FAILED ("WRONG VALUE FOR LAST - INTEGER: -56"); + END IF; + + IF CHARACTER'IMAGE(IDENT_CHAR('B'))'LAST /= IDENT_INT(3) THEN + FAILED ("WRONG VALUE FOR LAST - CHAR: 'B'"); + END IF; + + DECLARE + + FOUR_VAR : STRING(ENUM'IMAGE(FOUR)'RANGE); + C_VAR : STRING(ENUM'IMAGE('C')'RANGE); + VAR_101 : STRING(INTEGER'IMAGE(IDENT_INT(101))'RANGE); + CHAR_VAR : STRING(CHARACTER'IMAGE(IDENT_CHAR('B'))'RANGE); + + BEGIN + + IF FOUR_VAR'FIRST /= 1 OR + FOUR_VAR'LAST /= 4 OR + FOUR_VAR'LENGTH /= 4 THEN + FAILED ("FOUR_VAR ATTRIBUTES INCORRECT. FIRST IS" & + INTEGER'IMAGE(FOUR_VAR'FIRST) & ". LAST IS" & + INTEGER'IMAGE(FOUR_VAR'LAST) & ". LENGTH IS" & + INTEGER'IMAGE(FOUR_VAR'LENGTH)); + END IF; + + IF C_VAR'FIRST /= 1 OR + C_VAR'LAST /= 3 OR + C_VAR'LENGTH /= 3 THEN + FAILED ("C_VAR ATTRIBUTES INCORRECT. FIRST IS" & + INTEGER'IMAGE(C_VAR'FIRST) & ". LAST IS" & + INTEGER'IMAGE(C_VAR'LAST) & ". LENGTH IS" & + INTEGER'IMAGE(C_VAR'LENGTH)); + END IF; + + IF VAR_101'FIRST /= 1 OR + VAR_101'LAST /= 4 OR + VAR_101'LENGTH /= 4 THEN + FAILED ("VAR_101 ATTRIBUTES INCORRECT. FIRST IS" & + INTEGER'IMAGE(VAR_101'FIRST) & ". LAST IS" & + INTEGER'IMAGE(VAR_101'LAST) & ". LENGTH IS" & + INTEGER'IMAGE(VAR_101'LENGTH)); + END IF; + + IF CHAR_VAR'FIRST /= 1 OR + CHAR_VAR'LAST /= 3 OR + CHAR_VAR'LENGTH /= 3 THEN + FAILED ("CHAR_VAR ATTRIBUTES INCORRECT. FIRST IS" & + INTEGER'IMAGE(CHAR_VAR'FIRST) & ". LAST IS" & + INTEGER'IMAGE(CHAR_VAR'LAST) & ". LENGTH IS" & + INTEGER'IMAGE(CHAR_VAR'LENGTH)); + END IF; + + END; + + RESULT; +END C41404A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c420001.a b/gcc/testsuite/ada/acats/tests/c4/c420001.a new file mode 100644 index 000000000..ae4b4d8fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c420001.a @@ -0,0 +1,110 @@ +-- C420001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and +-- F08630-91-C-0015, 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 WHATSOVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE +-- Check that if the index subtype of a string type is a modular subtype +-- whose lower bound is zero, then the evaluation of a null string_literal +-- raises Constraint_Error. This was confirmed by AI95-00138. +-- +-- TEST DESCRIPTION +-- In this test, we have a generic formal modular type, and we have +-- several null string literals of that type. Because the type is +-- generic formal, the string literals are not static, and therefore +-- the Constraint_Error should be detected at run time. +-- +-- CHANGE HISTORY: +-- 29 JUN 1999 RAD Initial Version +-- 23 SEP 1999 RLB Improved comments and messages, renamed, issued. +-- +--! +with Report; use Report; pragma Elaborate_All(Report); +with System; +procedure C420001 is + generic + type Modular is mod <>; + package Mod_Test is + type Str is array(Modular range <>) of Character; + procedure Test_String_Literal; + end Mod_Test; + + package body Mod_Test is + procedure Test_String_Literal is + begin + begin + declare + Null_String: Str := ""; -- Should raise C_E. + begin + Comment(String(Null_String)); -- Avoid 11.6 issues. + end; + Failed("Null string didn't raise Constraint_Error"); + exception + when Exc: Constraint_Error => + null; -- Comment("Constraint_Error -- OK"); + when Exc2: others => + Failed("Null string raised wrong exception"); + end; + begin + Failed(String(Str'(""))); -- Should raise C_E, not do Failed. + Failed("Null string didn't raise Constraint_Error"); + exception + when Exc: Constraint_Error => + null; -- Comment("Constraint_Error -- OK"); + when Exc2: others => + Failed("Null string raised wrong exception"); + end; + end Test_String_Literal; + begin + Test_String_Literal; + end Mod_Test; +begin + Test("C420001", "Check that if the index subtype of a string type is a " & + "modular subtype whose lower bound is zero, then the " & + "evaluation of a null string_literal raises " & + "Constraint_Error. "); + declare + type M1 is mod 1; + package Test_M1 is new Mod_Test(M1); + type M2 is mod 2; + package Test_M2 is new Mod_Test(M2); + type M3 is mod 3; + package Test_M3 is new Mod_Test(M3); + type M4 is mod 4; + package Test_M4 is new Mod_Test(M4); + type M5 is mod 5; + package Test_M5 is new Mod_Test(M5); + type M6 is mod 6; + package Test_M6 is new Mod_Test(M6); + type M7 is mod 7; + package Test_M7 is new Mod_Test(M7); + type M8 is mod 8; + package Test_M8 is new Mod_Test(M8); + type M_Max_Binary_Modulus is mod System.Max_Binary_Modulus; + package Test_M_Max_Binary_Modulus is new Mod_Test(M_Max_Binary_Modulus); + type M_Max_Nonbinary_Modulus is mod System.Max_Nonbinary_Modulus; + package Test_M_Max_Nonbinary_Modulus is new Mod_Test(M_Max_Nonbinary_Modulus); + begin + null; + end; + Result; +end C420001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c42006a.ada b/gcc/testsuite/ada/acats/tests/c4/c42006a.ada new file mode 100644 index 000000000..6c2201704 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c42006a.ada @@ -0,0 +1,99 @@ +-- C42006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN A STRING LITERAL OF AN +-- ARRAY TYPE CONTAINS A CHARACTER THAT DOES NOT BELONG TO THE COMPONENT +-- SUBTYPE. + +-- SPS 2/22/84 +-- EDS 12/02/97 MODIFIED THE COMPONENT SUBTYPES SO THAT THEY ARE NON-STATIC. +-- EDS 7/14/98 AVOID OPTIMIZATION + +WITH REPORT; +USE REPORT; +PROCEDURE C42006A IS +BEGIN + + TEST ("C42006A", "CHECK THAT THE VALUES OF STRING LITERALS MUST" & + " BELONG TO THE COMPONENT SUBTYPE."); + + DECLARE + + TYPE CHAR_COMP IS ('A', 'B', 'C', 'D', 'E', 'F'); + + ASCIINUL : CHARACTER := ASCII.NUL; + SUBTYPE NON_GRAPHIC_CHAR IS CHARACTER + RANGE ASCIINUL .. ASCII.BEL; + + BEE : CHAR_COMP := 'B'; + TYPE CHAR_STRING IS ARRAY (POSITIVE RANGE <>) + OF CHAR_COMP RANGE BEE..'C'; + TYPE NON_GRAPHIC_CHAR_STRING IS ARRAY (POSITIVE RANGE <>) + OF NON_GRAPHIC_CHAR; + + C_STR : CHAR_STRING (1 .. 1); + C_STR_5 : CHAR_STRING (1 .. 5) := "BBBBB"; + N_G_STR : NON_GRAPHIC_CHAR_STRING (1 .. 1) := + (OTHERS => NON_GRAPHIC_CHAR'FIRST); + + BEGIN + + BEGIN + C_STR_5 := "BABCC"; -- 'A' NOT IN COMPONENT SUBTYPE. + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1 " & + CHAR_COMP'IMAGE(C_STR_5(1))); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 1"); + END; + + BEGIN + C_STR_5 := "BCBCD"; -- 'D' NOT IN COMPONENT SUBTYPE. + FAILED ("CONSTRAINT_ERROR NOT RAISED - 2 " & + CHAR_COMP'IMAGE(C_STR_5(1))); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 2"); + END; + + BEGIN + N_G_STR := "Z"; + FAILED ("CONSTRAINT_ERROR NOT RAISED - 3 " & + INTEGER'IMAGE(CHARACTER'POS(N_G_STR(1)))); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 3"); + END; + + END; + + RESULT; + +END C42006A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c42007e.ada b/gcc/testsuite/ada/acats/tests/c4/c42007e.ada new file mode 100644 index 000000000..09fd6e6ef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c42007e.ada @@ -0,0 +1,117 @@ +-- C42007E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF A STRING LITERAL ARE DETERMINED CORRECTLY. +-- IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY 'FIRST OF THE +-- INDEX SUBTYPE WHEN THE STRING LITERAL IS USED AS: + +-- E) THE LEFT OR RIGHT OPERAND OF "&". + +-- TBN 7/28/86 + +WITH REPORT; USE REPORT; +PROCEDURE C42007E IS + +BEGIN + + TEST("C42007E", "CHECK THE BOUNDS OF A STRING LITERAL WHEN USED " & + "AS THE LEFT OR RIGHT OPERAND OF THE CATENATION " & + "OPERATOR"); + + BEGIN + +CASE_E : DECLARE + + SUBTYPE STR_RANGE IS INTEGER RANGE 2 .. 10; + TYPE STR IS ARRAY (STR_RANGE RANGE <>) OF CHARACTER; + + FUNCTION CONCAT1 RETURN STR IS + BEGIN + RETURN ("ABC" & (7 .. 8 => 'D')); + END CONCAT1; + + FUNCTION CONCAT2 RETURN STR IS + BEGIN + RETURN ((IDENT_INT(4) .. 3 => 'A') & "BC"); + END CONCAT2; + + FUNCTION CONCAT3 RETURN STRING IS + BEGIN + RETURN ("TEST" & (7 .. 8 => 'X')); + END CONCAT3; + + FUNCTION CONCAT4 RETURN STRING IS + BEGIN + RETURN ((8 .. 5 => 'A') & "DE"); + END CONCAT4; + + BEGIN + + IF CONCAT1'FIRST /= IDENT_INT(2) THEN + FAILED ("LOWER BOUND INCORRECTLY DETERMINED - 1"); + END IF; + IF CONCAT1'LAST /= 6 THEN + FAILED ("UPPER BOUND INCORRECTLY DETERMINED - 1"); + END IF; + IF CONCAT1 /= "ABCDD" THEN + FAILED ("STRING INCORRECTLY DETERMINED - 1"); + END IF; + + IF CONCAT2'FIRST /= IDENT_INT(2) THEN + FAILED ("LOWER BOUND INCORRECTLY DETERMINED - 2"); + END IF; + IF CONCAT2'LAST /= 3 THEN + FAILED ("UPPER BOUND INCORRECTLY DETERMINED - 2"); + END IF; + IF CONCAT2 /= "BC" THEN + FAILED ("STRING INCORRECTLY DETERMINED - 2"); + END IF; + + IF CONCAT3'FIRST /= IDENT_INT(1) THEN + FAILED ("LOWER BOUND INCORRECTLY DETERMINED - 3"); + END IF; + IF CONCAT3'LAST /= 6 THEN + FAILED ("UPPER BOUND INCORRECTLY DETERMINED - 3"); + END IF; + IF CONCAT3 /= "TESTXX" THEN + FAILED ("STRING INCORRECTLY DETERMINED - 3"); + END IF; + + IF CONCAT4'FIRST /= IDENT_INT(1) THEN + FAILED ("LOWER BOUND INCORRECTLY DETERMINED - 4"); + END IF; + IF CONCAT4'LAST /= 2 THEN + FAILED ("UPPER BOUND INCORRECTLY DETERMINED - 4"); + END IF; + IF CONCAT4 /= "DE" THEN + FAILED ("STRING INCORRECTLY DETERMINED - 4"); + END IF; + + END CASE_E; + + END; + + RESULT; + +END C42007E; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43003a.ada b/gcc/testsuite/ada/acats/tests/c4/c43003a.ada new file mode 100644 index 000000000..976788118 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43003a.ada @@ -0,0 +1,64 @@ +-- C43003A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT WHEN INITIALIZING AN ARRAY OF ACCESS OBJECTS, WITH +-- AN AGGREGATE CONTAINING A SINGLE ALLOCATOR, ALL ELEMENTS +-- ARE INITIALIZED TO THE SAME INITIAL VALUE. +-- THAT IS, CHECK THAT ALL COMPONENTS OF THE ARRAY DESIGNATE +-- DISTINCT OBJECTS. + +-- DAT 3/18/81 +-- SPS 10/26/82 +-- JBG 12/27/82 +-- R. WILLIAMS 11/11/86 RENAMED FROM C38007A-B.ADA. + +WITH REPORT; USE REPORT; + +PROCEDURE C43003A IS + + TYPE AI IS ACCESS INTEGER; + + TYPE AAI IS ARRAY (1..5) OF AI; + + A : AAI := AAI'(OTHERS => NEW INTEGER '(2)); + +BEGIN + TEST ("C43003A", "CHECK THAT ALLOCATORS IN INITIALIZATIONS" + & " FOR ARRAYS OF ACCESS VALUES ARE EVALUATED ONCE" & + " FOR EACH COMPONENT"); + + FOR I IN 1..5 + LOOP + FOR J IN I+1..5 + LOOP + IF A(I) = A(J) THEN + FAILED ("DID NOT EVALUATE ALLOCATOR FOR EACH " & + "COMPONENT"); + EXIT; + END IF; + END LOOP; + END LOOP; + + RESULT; +END C43003A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43004a.ada b/gcc/testsuite/ada/acats/tests/c4/c43004a.ada new file mode 100644 index 000000000..86e705de7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43004a.ada @@ -0,0 +1,350 @@ +-- C43004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF A VALUE FOR A +-- NON-DISCRIMINANT SCALAR COMPONENT OF AN AGGREGATE IS NOT +-- WITHIN THE RANGE OF THE COMPONENT'S SUBTYPE. + +-- HISTORY: +-- BCB 01/22/88 CREATED ORIGINAL TEST. +-- RJW 06/27/90 CORRECTED CONSTRAINTS OF TYPE DFIX. +-- LDC 09/25/90 ADDED A BLOCK IN THE EXCEPTION HANDLER SO IT CAN +-- NOT OPTIMIZE IT AWAY, ALSO INITIALIZED EACH +-- OBJECT TO VALID DATA BEFORE DOING THE INVALID, +-- MADE 'IDENT_XXX' FUNCTIONS SO THE COMPILER CAN +-- NOT JUST EVALUATE THE ASSIGNMENT AND PUT IN CODE +-- FOR A CONSTRAINT ERROR IN IS PLACE. +-- JRL 06/07/96 Changed value in aggregate in subtest 4 to value +-- guaranteed to be in the base range of the type FIX. +-- Corrected typo. + +WITH REPORT; USE REPORT; + +PROCEDURE C43004A IS + + TYPE INT IS RANGE 1 .. 8; + SUBTYPE SINT IS INT RANGE 2 .. 7; + + TYPE ENUM IS (VINCE, JOHN, TOM, PHIL, ROSA, JODIE, BRIAN, DAVE); + SUBTYPE SENUM IS ENUM RANGE JOHN .. BRIAN; + + TYPE FL IS DIGITS 5 RANGE 0.0 .. 10.0; + SUBTYPE SFL IS FL RANGE 1.0 .. 9.0; + + TYPE FIX IS DELTA 0.25 RANGE 0.0 .. 8.0; + SUBTYPE SFIX IS FIX RANGE 1.0 .. 7.0; + + TYPE DINT IS NEW INTEGER RANGE 1 .. 8; + SUBTYPE SDINT IS DINT RANGE 2 .. 7; + + TYPE DENUM IS NEW ENUM RANGE VINCE .. DAVE; + SUBTYPE SDENUM IS DENUM RANGE JOHN .. BRIAN; + + TYPE DFL IS NEW FLOAT RANGE 0.0 .. 10.0; + SUBTYPE SDFL IS DFL RANGE 1.0 .. 9.0; + + TYPE DFIX IS NEW FIX RANGE 0.5 .. 7.5; + SUBTYPE SDFIX IS DFIX RANGE 1.0 .. 7.0; + + TYPE REC1 IS RECORD + E1, E2, E3, E4, E5 : SENUM; + END RECORD; + + TYPE REC2 IS RECORD + E1, E2, E3, E4, E5 : SFIX; + END RECORD; + + TYPE REC3 IS RECORD + E1, E2, E3, E4, E5 : SDENUM; + END RECORD; + + TYPE REC4 IS RECORD + E1, E2, E3, E4, E5 : SDFIX; + END RECORD; + + ARRAY_OBJ : ARRAY(1..2) OF INTEGER; + + A : ARRAY(1..5) OF SINT; + B : REC1; + C : ARRAY(1..5) OF SFL; + D : REC2; + E : ARRAY(1..5) OF SDINT; + F : REC3; + G : ARRAY(1..5) OF SDFL; + H : REC4; + + GENERIC + TYPE GENERAL_PURPOSE IS PRIVATE; + FUNCTION GENEQUAL(ONE, TWO : GENERAL_PURPOSE) RETURN BOOLEAN; + + FUNCTION GENEQUAL(ONE, TWO : GENERAL_PURPOSE) RETURN BOOLEAN IS + BEGIN + IF EQUAL(3,3) THEN + RETURN ONE = TWO; + ELSE + RETURN ONE /= TWO; + END IF; + END GENEQUAL; + + FUNCTION EQUAL IS NEW GENEQUAL(SENUM); + FUNCTION EQUAL IS NEW GENEQUAL(SFL); + FUNCTION EQUAL IS NEW GENEQUAL(SFIX); + FUNCTION EQUAL IS NEW GENEQUAL(SDENUM); + FUNCTION EQUAL IS NEW GENEQUAL(SDFL); + FUNCTION EQUAL IS NEW GENEQUAL(SDFIX); + + GENERIC + TYPE GENERAL_PURPOSE IS PRIVATE; + WITH FUNCTION EQUAL_GENERAL(ONE, TWO : GENERAL_PURPOSE) + RETURN BOOLEAN; + FUNCTION GEN_IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE; + FUNCTION GEN_IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE IS + BEGIN + IF EQUAL_GENERAL (X, X) THEN -- ALWAYS EQUAL. + RETURN X; -- ALWAYS EXECUTED. + END IF; + -- NEVER EXECUTED. + RETURN X; + END GEN_IDENT; + + FUNCTION IDENT_FL IS NEW GEN_IDENT(FL, EQUAL); + FUNCTION IDENT_FIX IS NEW GEN_IDENT(FIX, EQUAL); + FUNCTION IDENT_DFL IS NEW GEN_IDENT(DFL, EQUAL); + FUNCTION IDENT_DFIX IS NEW GEN_IDENT(DFIX, EQUAL); + +BEGIN + TEST ("C43004A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF A " & + "VALUE FOR A NON-DISCRIMINANT SCALAR COMPONENT " & + "OF AN AGGREGATE IS NOT WITHIN THE RANGE OF " & + "THE COMPONENT'S SUBTYPE"); + + ARRAY_OBJ := (1, 2); + + BEGIN + A := (2,3,4,5,6); -- OK + + IF EQUAL (INTEGER (A(IDENT_INT(1))), + INTEGER (A(IDENT_INT(2)))) THEN + COMMENT ("DON'T OPTIMIZE A"); + END IF; + + A := (SINT(IDENT_INT(1)),2,3,4,7); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH INTEGER COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 1"); + IF EQUAL (INTEGER (A(IDENT_INT(1))), + INTEGER (A(IDENT_INT(1)))) THEN + COMMENT ("DON'T OPTIMIZE A"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 1"); + END; + + BEGIN + B := (JOHN,TOM,PHIL,ROSA,JOHN); -- OK + + IF EQUAL (B.E1, B.E2) THEN + COMMENT ("DON'T OPTIMIZE B"); + END IF; + + B := (ENUM'VAL(IDENT_INT(ENUM'POS(DAVE))), TOM, PHIL, + ROSA, JODIE); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH COMPONENTS OF AN + -- ENUMERATION TYPE. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 2"); + IF NOT EQUAL (B.E1, B.E1) THEN + COMMENT ("DON'T OPTIMIZE B"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 2"); + END; + BEGIN + C := (2.0,3.0,4.0,5.0,6.0); -- OK + IF EQUAL (C(IDENT_INT(1)), C(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE C"); + END IF; + + C := (IDENT_FL(1.0),2.0,3.0,4.0,IDENT_FL(10.0)); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH FLOATING POINT COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 3"); + IF NOT EQUAL (C(IDENT_INT(1)), C(IDENT_INT(1))) THEN + COMMENT ("DON'T OPTIMIZE C"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 3"); + END; + + BEGIN + D := (2.2,3.3,4.4,5.5,6.6); -- OK + IF EQUAL (D.E1, D.E5) THEN + COMMENT ("DON'T OPTIMIZE D"); + END IF; + + D := (IDENT_FIX(1.0),2.1,3.3,4.4,IDENT_FIX(7.75)); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH FIXED POINT COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 4"); + IF NOT EQUAL (D.E5, D.E5) THEN + COMMENT ("DON'T OPTIMIZE D"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 4"); + END; + + BEGIN + E := (2,3,4,5,6); -- OK + IF EQUAL (INTEGER (E(IDENT_INT(1))), + INTEGER (E(IDENT_INT(2)))) THEN + COMMENT ("DON'T OPTIMIZE E"); + END IF; + + E := (SDINT(IDENT_INT(1)),2,3,4,7); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH DERIVED INTEGER COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 5"); + IF NOT EQUAL (INTEGER (E(IDENT_INT(1))), + INTEGER (E(IDENT_INT(1)))) THEN + COMMENT ("DON'T OPTIMIZE E"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 5"); + END; + + BEGIN + F := (JOHN,TOM,PHIL,ROSA,JOHN); -- OK + IF EQUAL (F.E1, F.E2) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + + F := (DENUM'VAL(IDENT_INT(DENUM'POS(VINCE))), TOM, PHIL, + ROSA, JODIE); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH COMPONENTS OF A DERIVED + -- ENUMERATION TYPE. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 6"); + IF NOT EQUAL (F.E1, F.E1) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 6"); + END; + + BEGIN + G := (2.0,3.0,4.0,5.0,6.0); -- OK + IF EQUAL (G(IDENT_INT(1)), G(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE G"); + END IF; + + G := (IDENT_DFL(1.0),2.0,3.0,4.0,IDENT_DFL(10.0)); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH DERIVED FLOATING POINT + -- COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 7"); + IF NOT EQUAL (G(IDENT_INT(1)), G(IDENT_INT(1))) THEN + COMMENT ("DON'T OPTIMIZE G"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 7"); + END; + + BEGIN + H := (2.2,3.3,4.4,5.5,6.6); -- OK + IF EQUAL (H.E1, H.E2) THEN + COMMENT ("DON'T OPTIMIZE H"); + END IF; + + H := (IDENT_DFIX(2.0),2.5,3.5,4.3,IDENT_DFIX(7.4)); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH DERIVED FIXED POINT + -- COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 8"); + IF EQUAL (H.E1, H.E5) THEN + COMMENT ("DON'T OPTIMIZE H"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 8"); + END; + + + RESULT; +END C43004A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43004c.ada b/gcc/testsuite/ada/acats/tests/c4/c43004c.ada new file mode 100644 index 000000000..253467477 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43004c.ada @@ -0,0 +1,230 @@ +-- C43004C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE VALUE OF A +-- DISCRIMINANT OF A CONSTRAINED COMPONENT OF AN AGGREGATE DOES +-- NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE FOR THE +-- COMPONENT'S SUBTYPE. + +-- HISTORY: +-- BCB 07/19/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C43004C IS + + ZERO : INTEGER := 0; + + TYPE REC (D : INTEGER := 0) IS RECORD + COMP1 : INTEGER; + END RECORD; + + TYPE DREC (DD : INTEGER := ZERO) IS RECORD + DCOMP1 : INTEGER; + END RECORD; + + TYPE REC1 IS RECORD + A : REC(0); + END RECORD; + + TYPE REC2 IS RECORD + B : DREC(ZERO); + END RECORD; + + TYPE REC3 (D3 : INTEGER := 0) IS RECORD + C : REC(D3); + END RECORD; + + V : REC1; + W : REC2; + X : REC3; + + PACKAGE P IS + TYPE PRIV1 (D : INTEGER := 0) IS PRIVATE; + TYPE PRIV2 (DD : INTEGER := ZERO) IS PRIVATE; + FUNCTION INIT (I : INTEGER) RETURN PRIV1; + PRIVATE + TYPE PRIV1 (D : INTEGER := 0) IS RECORD + NULL; + END RECORD; + + TYPE PRIV2 (DD : INTEGER := ZERO) IS RECORD + NULL; + END RECORD; + END P; + + TYPE REC7 IS RECORD + H : P.PRIV1 (0); + END RECORD; + + Y : REC7; + + GENERIC + TYPE GP IS PRIVATE; + FUNCTION GEN_EQUAL (X, Y : GP) RETURN BOOLEAN; + + FUNCTION GEN_EQUAL (X, Y : GP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END GEN_EQUAL; + + PACKAGE BODY P IS + TYPE REC4 IS RECORD + E : PRIV1(0); + END RECORD; + + TYPE REC5 IS RECORD + F : PRIV2(ZERO); + END RECORD; + + TYPE REC6 (D6 : INTEGER := 0) IS RECORD + G : PRIV1(D6); + END RECORD; + + VV : REC4; + WW : REC5; + XX : REC6; + + FUNCTION REC4_EQUAL IS NEW GEN_EQUAL (REC4); + FUNCTION REC5_EQUAL IS NEW GEN_EQUAL (REC5); + FUNCTION REC6_EQUAL IS NEW GEN_EQUAL (REC6); + + FUNCTION INIT (I : INTEGER) RETURN PRIV1 IS + VAR : PRIV1; + BEGIN + VAR := (D => I); + RETURN VAR; + END INIT; + BEGIN + TEST ("C43004C", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "IF THE VALUE OF A DISCRIMINANT OF A " & + "CONSTRAINED COMPONENT OF AN AGGREGATE " & + "DOES NOT EQUAL THE CORRESPONDING " & + "DISCRIMINANT VALUE FOR THECOMPONENT'S " & + "SUBTYPE"); + + BEGIN + VV := (E => (D => 1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1"); + IF REC4_EQUAL (VV,VV) THEN + COMMENT ("DON'T OPTIMIZE VV"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 1"); + END; + + BEGIN + WW := (F => (DD => 1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 2"); + IF REC5_EQUAL (WW,WW) THEN + COMMENT ("DON'T OPTIMIZE WW"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 2"); + END; + + BEGIN + XX := (D6 => 1, G => (D => 5)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 3"); + IF REC6_EQUAL (XX,XX) THEN + COMMENT ("DON'T OPTIMIZE XX"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 3"); + END; + END P; + + USE P; + + FUNCTION REC1_EQUAL IS NEW GEN_EQUAL (REC1); + FUNCTION REC2_EQUAL IS NEW GEN_EQUAL (REC2); + FUNCTION REC3_EQUAL IS NEW GEN_EQUAL (REC3); + FUNCTION REC7_EQUAL IS NEW GEN_EQUAL (REC7); + +BEGIN + + BEGIN + V := (A => (D => 1, COMP1 => 2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 4"); + IF REC1_EQUAL (V,V) THEN + COMMENT ("DON'T OPTIMIZE V"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 4"); + END; + + BEGIN + W := (B => (DD => 1, DCOMP1 => 2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 5"); + IF REC2_EQUAL (W,W) THEN + COMMENT ("DON'T OPTIMIZE W"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 5"); + END; + + BEGIN + X := (D3 => 1, C => (D => 5, COMP1 => 2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 6"); + IF REC3_EQUAL (X,X) THEN + COMMENT ("DON'T OPTIMIZE X"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 6"); + END; + + BEGIN + Y := (H => INIT (1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 7"); + IF REC7_EQUAL (Y,Y) THEN + COMMENT ("DON'T OPTIMIZE Y"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 7"); + END; + + RESULT; +END C43004C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c431001.a b/gcc/testsuite/ada/acats/tests/c4/c431001.a new file mode 100644 index 000000000..7d417ce69 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c431001.a @@ -0,0 +1,464 @@ +-- C431001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a record aggregate can be given for a nonprivate, +-- nonlimited record extension and that the tag of the aggregate +-- values are initialized to the tag of the record extension. +-- +-- TEST DESCRIPTION: +-- From an initial parent tagged type, several type extensions +-- are declared. Each type extension adds components onto +-- the existing record structure. +-- +-- In the main procedure, aggregates are declared in two ways. +-- In the declarative part, aggregates are used to supply +-- initial values for objects of specific types. In the executable +-- part, aggregates are used directly as actual parameters to +-- a class-wide formal parameter. +-- +-- The abstraction is for a catalog of recordings. A recording +-- can be a CD or a record (vinyl). Additionally, a CD may also +-- be a CD-ROM, containing both music and data. This type is declared +-- as an extension to a type extension, to test that the inclusion +-- of record components is transitive across multiple extensions. +-- +-- That the aggregate has the correct tag is verify by feeding +-- it to a dispatching operation and confirming that the +-- expected subprogram is called as a result. To accomplish this, +-- an enumeration type is declared with an enumeration literal +-- representing each of the declared types in the hierarchy. A value +-- of this type is passed as a parameter to the dispatching +-- operation which passes it along to the dispatched subprogram. +-- Each dispatched subprogram verifies that it received the +-- expected enumeration literal. +-- +-- Not quite fitting the above abstraction are several test cases +-- for null records. These tests verify that the new syntax for +-- null record aggregates, (null record), is supported. A type is +-- declared which extends a null tagged type and adds components. +-- Aggregates of this type should include associations for the +-- components of the type extension only. Finally, a type is +-- declared that adds a null type extension onto a non-null tagged +-- type. The aggregate associations should remain the same. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Removed RM references from objective text. +-- +--! +-- +package C431001_0 is + + -- Values of TC_Type_ID are passed through to dispatched subprogram + -- calls so that it can be verified that the dispatching resulted in + -- the expected call. + type TC_Type_ID is (TC_Recording, TC_CD, TC_Vinyl, TC_CD_ROM); + + type Genre is (Classical, Country, Jazz, Rap, Rock, World); + + type Recording is tagged record + Artist : String (1..20); + Category : Genre; + Length : Duration; + Selections : Positive; + end record; + + function Summary (R : in Recording; + TC_Type : in TC_Type_ID) return String; + + type Recording_Method is (Audio, Digital); + type CD is new Recording with record + Recorded : Recording_Method; + Mastered : Recording_Method; + end record; + + function Summary (Disc : in CD; + TC_Type : in TC_Type_ID) return String; + + type Playing_Speed is (LP_33, Single_45, Old_78); + type Vinyl is new Recording with record + Speed : Playing_Speed; + end record; + + function Summary (Album : in Vinyl; + TC_Type : in TC_Type_ID) return String; + + + type CD_ROM is new CD with record + Storage : Positive; + end record; + + function Summary (Disk : in CD_ROM; + TC_Type : in TC_Type_ID) return String; + + function Catalog_Entry (R : in Recording'Class; + TC_Type : in TC_Type_ID) return String; + + procedure Print (S : in String); -- provides somewhere for the + -- results of Catalog_Entry to + -- "go", so they don't get + -- optimized away. + + -- The types and procedures declared below are not a continuation + -- of the Recording abstraction. These types are intended to test + -- support for null tagged types and type extensions. TC_Check mirrors + -- the operation of function Summary, above. Similarly, TC_Dispatch + -- mirrors the operation of Catalog_Entry. + + type TC_N_Type_ID is + (TC_Null_Tagged, TC_Null_Extension, + TC_Extension_Of_Null, TC_Null_Extension_Of_Nonnull); + + type Null_Tagged is tagged null record; + procedure TC_Check (N : in Null_Tagged; + TC_Type : in TC_N_Type_ID); + + type Null_Extension is new Null_Tagged with null record; + procedure TC_Check (N : in Null_Extension; + TC_Type : in TC_N_Type_ID); + + type Extension_Of_Null is new Null_Tagged with record + New_Component1 : Boolean; + New_Component2 : Natural; + end record; + procedure TC_Check (N : in Extension_Of_Null; + TC_Type : in TC_N_Type_ID); + + type Null_Extension_Of_Nonnull is new Extension_Of_Null + with null record; + procedure TC_Check (N : in Null_Extension_Of_Nonnull; + TC_Type : in TC_N_Type_ID); + + procedure TC_Dispatch (N : in Null_Tagged'Class; + TC_Type : in TC_N_Type_ID); + +end C431001_0; + +with Report; +package body C431001_0 is + + function Summary (R : in Recording; + TC_Type : in TC_Type_ID) return String is + begin + + if TC_Type /= TC_Recording then + Report.Failed ("Did not dispatch on tag for tagged parent " & + "type Recording"); + end if; + + return R.Artist (1..10) + & ' ' & Genre'Image (R.Category) (1..2) + & ' ' & Duration'Image (R.Length) + & ' ' & Integer'Image (R.Selections); + + end Summary; + + function Summary (Disc : in CD; + TC_Type : in TC_Type_ID) return String is + begin + + if TC_Type /= TC_CD then + Report.Failed ("Did not dispatch on tag for type extension " & + "CD"); + end if; + + return Summary (Recording (Disc), TC_Type => TC_Recording) + & ' ' & Recording_Method'Image(Disc.Recorded)(1) + & Recording_Method'Image(Disc.Mastered)(1); + + end Summary; + + function Summary (Album : in Vinyl; + TC_Type : in TC_Type_ID) return String is + begin + if TC_Type /= TC_Vinyl then + Report.Failed ("Did not dispatch on tag for type extension " & + "Vinyl"); + end if; + + case Album.Speed is + when LP_33 => + return Summary (Recording (Album), TC_Type => TC_Recording) + & " 33"; + when Single_45 => + return Summary (Recording (Album), TC_Type => TC_Recording) + & " 45"; + when Old_78 => + return Summary (Recording (Album), TC_Type => TC_Recording) + & " 78"; + end case; + + end Summary; + + function Summary (Disk : in CD_ROM; + TC_Type : in TC_Type_ID) return String is + begin + if TC_Type /= TC_CD_ROM then + Report.Failed ("Did not dispatch on tag for type extension " & + "CD_ROM. This is an extension of the type " & + "extension CD"); + end if; + + return Summary (Recording(Disk), TC_Type => TC_Recording) + & ' ' & Integer'Image (Disk.Storage) & 'K'; + + end Summary; + + function Catalog_Entry (R : in Recording'Class; + TC_Type : in TC_Type_ID) return String is + begin + return Summary (R, TC_Type); -- dispatched call + end Catalog_Entry; + + procedure Print (S : in String) is + T : String (1..S'Length) := Report.Ident_Str (S); + begin + -- Ada.Text_IO.Put_Line (S); + null; + end Print; + + -- Bodies for null type checks + procedure TC_Check (N : in Null_Tagged; + TC_Type : in TC_N_Type_ID) is + begin + if TC_Type /= TC_Null_Tagged then + Report.Failed ("Did not dispatch on tag for null tagged " & + "type Null_Tagged"); + end if; + end TC_Check; + + procedure TC_Check (N : in Null_Extension; + TC_Type : in TC_N_Type_ID) is + begin + if TC_Type /= TC_Null_Extension then + Report.Failed ("Did not dispatch on tag for null tagged " & + "type extension Null_Extension"); + end if; + end TC_Check; + + procedure TC_Check (N : in Extension_Of_Null; + TC_Type : in TC_N_Type_ID) is + begin + if TC_Type /= TC_Extension_Of_Null then + Report.Failed + ("Did not dispatch on tag for extension of null parent" & + "type"); + end if; + end TC_Check; + + procedure TC_Check (N : in Null_Extension_Of_Nonnull; + TC_Type : in TC_N_Type_ID) is + begin + if TC_Type /= TC_Null_Extension_Of_Nonnull then + Report.Failed + ("Did not dispatch on tag for null extension of nonnull " & + "parent type"); + end if; + end TC_Check; + + procedure TC_Dispatch (N : in Null_Tagged'Class; + TC_Type : in TC_N_Type_ID) is + begin + TC_Check (N, TC_Type); -- dispatched call + end TC_Dispatch; + +end C431001_0; + + +with C431001_0; +with Report; +procedure C431001 is + + -- Tagged type + -- Named component associations + DAT : C431001_0.Recording := + (Artist => "Aerosmith ", + Category => C431001_0.Rock, + Length => 48.5, + Selections => 10); + + -- Type extensions + -- Named component associations + Disc1 : C431001_0.CD := + (Artist => "London Symphony ", + Category => C431001_0.Classical, + Length => 55.0, + Selections => 4, + Recorded => C431001_0.Digital, + Mastered => C431001_0.Digital); + + -- Named component associations with others + Disc2 : C431001_0.CD := + (Artist => "Pink Floyd ", + Category => C431001_0.Rock, + Length => 51.8, + Selections => 5, + others => C431001_0.Audio); -- Recorded + -- Mastered + + -- Positional component associations + Album1 : C431001_0.Vinyl := + ("Hammer ", -- Artist + C431001_0.Rap, -- Category + 46.2, -- Length + 9, -- Selections + C431001_0.LP_33); -- Speed + + -- Mixed positional and named component associations + -- Named component associations out of order + Album2 : C431001_0.Vinyl := + ("Balinese Gamelan ", -- Artist + C431001_0.World, -- Category + 42.6, -- Length + 14, -- Selections + C431001_0.LP_33); -- Speed + + -- Type extension, parent is also type extension + -- Named notation, components out of order + Data : C431001_0.CD_ROM := + (Storage => 140, + Mastered => C431001_0.Digital, + Category => C431001_0.Rock, + Selections => 10, + Recorded => C431001_0.Digital, + Artist => "Black, Clint ", + Length => 48.5); + + -- Null tagged type + Null_Rec : C431001_0.Null_Tagged := (null record); + + -- Null type extension + Null_Ext : C431001_0.Null_Extension := (null record); + + -- Nonnull extension of null parent + Ext_Of_Null : C431001_0.Extension_Of_Null := (True, 0); + + -- Null extension of nonnull parent + Null_Ext_Of_Nonnull : C431001_0.Null_Extension_Of_Nonnull + := (False, 1); + +begin + + Report.Test ("C431001", "Aggregate values for type extensions"); + + C431001_0.Print (C431001_0.Catalog_Entry (DAT, C431001_0.TC_Recording)); + C431001_0.Print (C431001_0.Catalog_Entry (Disc1, C431001_0.TC_CD)); + C431001_0.Print (C431001_0.Catalog_Entry (Disc2, C431001_0.TC_CD)); + C431001_0.Print (C431001_0.Catalog_Entry (Album1, C431001_0.TC_Vinyl)); + C431001_0.Print (C431001_0.Catalog_Entry (Album2, C431001_0.TC_Vinyl)); + C431001_0.Print (C431001_0.Catalog_Entry (Data, C431001_0.TC_CD_ROM)); + + C431001_0.TC_Dispatch (Null_Rec, C431001_0.TC_Null_Tagged); + C431001_0.TC_Dispatch (Null_Ext, C431001_0.TC_Null_Extension); + C431001_0.TC_Dispatch (Ext_Of_Null, C431001_0.TC_Extension_Of_Null); + C431001_0.TC_Dispatch + (Null_Ext_Of_Nonnull, C431001_0.TC_Null_Extension_Of_Nonnull); + + -- Tagged type + -- Named component associations + C431001_0.Print (C431001_0.Catalog_Entry + (TC_Type => C431001_0.TC_Recording, + R => C431001_0.Recording'(Artist => "Zappa, Frank ", + Category => C431001_0.Rock, + Length => 70.0, + Selections => 38))); + + -- Type extensions + -- Named component associations + C431001_0.Print (C431001_0.Catalog_Entry + (TC_Type => C431001_0.TC_CD, + R => C431001_0.CD'(Artist => "Dog, Snoop Doggy ", + Category => C431001_0.Rap, + Length => 37.3, + Selections => 8, + Recorded => C431001_0.Audio, + Mastered => C431001_0.Digital))); + + -- Named component associations with others + C431001_0.Print (C431001_0.Catalog_Entry + (TC_Type => C431001_0.TC_CD, + R => C431001_0.CD'(Artist => "Judd, Winona ", + Category => C431001_0.Country, + Length => 51.2, + Selections => 11, + others => C431001_0.Digital))); -- Recorded + -- Mastered + + -- Positional component associations + C431001_0.Print (C431001_0.Catalog_Entry + (TC_Type => C431001_0.TC_Vinyl, + R => C431001_0.Vinyl'("Davis, Miles ", -- Artist + C431001_0.Jazz, -- Category + 50.4, -- Length + 10, -- Selections + C431001_0.LP_33))); -- Speed + + -- Mixed positional and named component associations + -- Named component associations out of order + C431001_0.Print (C431001_0.Catalog_Entry + (TC_Type => C431001_0.TC_Vinyl, + R => C431001_0.Vinyl'("Zamfir ", -- Artist + C431001_0.World, -- Category + Speed => C431001_0.LP_33, + Selections => 14, + Length => 56.5))); + + -- Type extension, parent is also type extension + -- Named notation, components out of order + C431001_0.Print (C431001_0.Catalog_Entry + (TC_Type => C431001_0.TC_CD_ROM, + R => C431001_0.CD_ROM'(Storage => 720, + Category => C431001_0.Classical, + Recorded => C431001_0.Digital, + Artist => "Baltimore Symphony ", + Length => 68.9, + Mastered => C431001_0.Digital, + Selections => 5))); + + -- Null tagged type + C431001_0.TC_Dispatch + (TC_Type => C431001_0.TC_Null_Tagged, + N => C431001_0.Null_Tagged'(null record)); + + -- Null type extension + C431001_0.TC_Dispatch + (TC_Type => C431001_0.TC_Null_Extension, + N => C431001_0.Null_Extension'(null record)); + + -- Nonnull extension of null parent + C431001_0.TC_Dispatch + (TC_Type => C431001_0.TC_Extension_Of_Null, + N => C431001_0.Extension_Of_Null'(True, 3)); + + -- Null extension of nonnull parent + C431001_0.TC_Dispatch + (TC_Type => C431001_0.TC_Extension_Of_Null, + N => C431001_0.Extension_Of_Null'(False, 4)); + + Report.Result; + +end C431001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43103a.ada b/gcc/testsuite/ada/acats/tests/c4/c43103a.ada new file mode 100644 index 000000000..4267f5895 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43103a.ada @@ -0,0 +1,127 @@ +-- C43103A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A DISCRIMINANT DOES NOT GOVERN A VARIANT PART, +-- ITS VALUE CAN BE GIVEN BY A NON-STATIC EXPRESSION. + +-- EG 02/13/84 + +WITH REPORT; + +PROCEDURE C43103A IS + + USE REPORT; + +BEGIN + + TEST("C43103A","CHECK THAT IF A DISCRIMINANT DOES NOT GOVERN " & + "A VARIANT PART, ITS VALUE CAN BE GIVEN BY A " & + "NON-STATIC EXPRESSION"); + + BEGIN + + COMMENT ("CASE A : DISCRIMINANT THAT IS NOT USED INSIDE " & + "THE RECORD"); + +CASE_A : DECLARE + + TYPE R1 (A : INTEGER) IS + RECORD + B : STRING(1 .. 2); + C : INTEGER; + END RECORD; + + A1 : R1(IDENT_INT(5)) := (IDENT_INT(5), "AB", -2); + + BEGIN + + IF A1.A /= IDENT_INT(5) OR A1.B /= "AB" OR + A1.C /= -2 THEN + FAILED ("CASE A : INCORRECT VALUES IN RECORD"); + END IF; + + END CASE_A; + + COMMENT ("CASE B : DISCRIMINANT THAT IS USED AS AN ARRAY " & + "INDEX BOUND"); + +CASE_B : DECLARE + + SUBTYPE STB IS INTEGER RANGE 1 .. 10; + TYPE TB IS ARRAY(STB RANGE <>) OF INTEGER; + TYPE R2 (A : STB) IS + RECORD + B : TB(1 .. A); + C : BOOLEAN; + END RECORD; + + B1 : R2(IDENT_INT(2)) := (IDENT_INT(2), (-1, -2), FALSE); + + BEGIN + + IF B1.B'LAST /= IDENT_INT(2) THEN + FAILED ("CASE B : INCORRECT UPPER BOUND"); + ELSIF B1.A /= IDENT_INT(2) OR B1.B /= (-1, -2) OR + B1.C /= FALSE THEN + FAILED ("CASE B : INCORRECT VALUES IN RECORD"); + END IF; + + END CASE_B; + + COMMENT ("CASE C : DISCRIMINANT THAT IS USED IN A " & + "DISCRIMINANT CONSTRAINT"); + +CASE_C : DECLARE + + SUBTYPE STC IS INTEGER RANGE 1 .. 10; + TYPE TC IS ARRAY(STC RANGE <>) OF INTEGER; + TYPE R3 (A : STC) IS + RECORD + B : TC(1 .. A); + C : INTEGER := -4; + END RECORD; + TYPE R4 (A : INTEGER) IS + RECORD + B : R3(A); + C : INTEGER; + END RECORD; + + C1 : R4(IDENT_INT(3)) := (IDENT_INT(3), + (IDENT_INT(3), (1, 2, 3), 4), + 5); + + BEGIN + + IF C1.B.B /= (1, 2, 3) OR C1.B.C /= 4 OR + C1.C /= 5 THEN + FAILED ("CASE C : INCORRECT VALUES IN RECORD"); + END IF; + + END CASE_C; + + END; + + RESULT; + +END C43103A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43103b.ada b/gcc/testsuite/ada/acats/tests/c4/c43103b.ada new file mode 100644 index 000000000..994e42459 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43103b.ada @@ -0,0 +1,186 @@ +-- C43103B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A DISCRIMINANT DOES NOT GOVERN A VARIANT PART, ITS +-- VALUE CAN BE GIVEN BY A NONSTATIC EXPRESSION. +-- ADDITIONAL CASES OF USE OF A DISCRIMINANT THAT IS USED AS AN +-- ARRAY INDEX BOUND. + +-- PK 02/21/84 +-- EG 05/30/84 +-- EG 11/02/84 +-- DN 12/01/95 REMOVED CONFORMANCE CHECKS WHERE RULES RELAXED. +-- PWN 10/25/96 RESTORED CHECK WITH ADA 95 EXPECTED RESULTS INCLUDED. + +WITH REPORT; +USE REPORT; + +PROCEDURE C43103B IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + + TYPE A2 IS ARRAY(INT RANGE <>, INT RANGE <>) OF INTEGER; + + SUBTYPE DINT IS INTEGER RANGE 0 .. 10; + + TYPE REC(D, E : DINT := IDENT_INT(1)) IS RECORD + U : A2(1 .. D, E .. 3) := (1 .. D => + (E .. 3 => IDENT_INT(1))); + END RECORD; + +BEGIN + + TEST("C43103B","CHECK THAT IF A DISCRIMINANT DOES NOT GOVERN " & + "A VARIANT PART, ITS VALUE CAN BE GIVEN BY A " & + "NONSTATIC EXPRESSION"); + +-- SIMPLE DECLARATIONS + + BEGIN + + DECLARE + + L : REC(IDENT_INT(2), IDENT_INT(2)); + K : REC(IDENT_INT(0), IDENT_INT(1)); + M : REC(IDENT_INT(3), IDENT_INT(4)); + + BEGIN + IF L.U'FIRST(1) /= IDENT_INT(1) OR + L.U'LAST(1) /= IDENT_INT(2) OR + L.U'FIRST(2) /= IDENT_INT(2) OR + L.U'LAST(2) /= IDENT_INT(3) THEN + FAILED("1.1 - INCORRECT BOUNDS"); + END IF; + IF K.U'FIRST(1) /= IDENT_INT(1) OR + K.U'LAST(1) /= IDENT_INT(0) OR + K.U'FIRST(2) /= IDENT_INT(1) OR + K.U'LAST(2) /= IDENT_INT(3) THEN + FAILED("1.2 - INCORRECT BOUNDS"); + END IF; + IF M.U'FIRST(1) /= IDENT_INT(1) OR + M.U'LAST(1) /= IDENT_INT(3) OR + M.U'FIRST(2) /= IDENT_INT(4) OR + M.U'LAST(2) /= IDENT_INT(3) THEN + FAILED("1.3 - INCORRECT BOUNDS"); + END IF; + IF M.U'LENGTH(1) /= 3 OR M.U'LENGTH(2) /= 0 THEN + FAILED("1.4 - INCORRECT ARRAY LENGTH"); + END IF; + END; + + EXCEPTION + + WHEN OTHERS => + FAILED ("1.5 - EXCEPTION RAISED"); + + END; + +-- EXPLICIT INITIAL VALUE - OK + + BEGIN + + DECLARE + O : CONSTANT REC := (IDENT_INT(2), IDENT_INT(2), + ((1, IDENT_INT(2)), (IDENT_INT(2), 3))); + BEGIN + IF O.U'FIRST(1) /= IDENT_INT(1) OR + O.U'LAST(1) /= IDENT_INT(2) OR + O.U'FIRST(2) /= IDENT_INT(2) OR + O.U'LAST(2) /= IDENT_INT(3) THEN + FAILED("2.1 - INCORRECT BOUNDS"); + END IF; + END; + + EXCEPTION + + WHEN OTHERS => + FAILED ("2.2 - EXCEPTION RAISED"); + END; + +-- EXPLICIT INITIAL VALUE: NULL ARRAY WITH WRONG BOUNDS + + BEGIN + + DECLARE + P : CONSTANT REC := (IDENT_INT(0), IDENT_INT(2), + (IDENT_INT(3) .. IDENT_INT(0) => + (IDENT_INT(2), 3))); + BEGIN + NULL; + END; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("3.1 - CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("3.2 - WRONG EXCEPTION RAISED"); + END; + +-- EXPLICIT INITIAL VALUE: NULL ARRAY WITH WRONG BOUNDS + + BEGIN + + DECLARE + P : CONSTANT REC := (IDENT_INT(0), IDENT_INT(2), + (IDENT_INT(3) .. IDENT_INT(0) => + (OTHERS => IDENT_INT(2)))); + BEGIN + NULL; + END; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("4.1 - CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("4.2 - WRONG EXCEPTION RAISED"); + + END; + +-- EXPLICIT INITIAL VALUE: NULL ARRAY WITH WRONG BOUNDS 2ND DIM. + + BEGIN + + DECLARE + P : CONSTANT REC := (IDENT_INT(0), IDENT_INT(2), + (IDENT_INT(1) .. IDENT_INT(0) => + (IDENT_INT(1) .. IDENT_INT(2) => + 1))); + BEGIN + NULL; + END; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("5.1 - CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("5.2 - WRONG EXCEPTION RAISED"); + + END; + + RESULT; + +END C43103B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43104a.ada b/gcc/testsuite/ada/acats/tests/c4/c43104a.ada new file mode 100644 index 000000000..3c1ee9dda --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43104a.ada @@ -0,0 +1,86 @@ +-- C43104A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT WITH THE TYPE OF THE AGGREGATE RESOLVED, THE +-- DISCRIMINANT MAY BE USED TO DECIDE TO WHICH OF THE VARIANT'S +-- SUBTYPES THE AGGREGATE BELONGS. + +-- HISTORY: +-- DHH 08/08/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43104A IS + + TYPE INT IS RANGE 0 .. 10; + + TYPE VAR_REC(BOOL : BOOLEAN := TRUE) IS + RECORD + CASE BOOL IS + WHEN TRUE => + X : INTEGER; + WHEN FALSE => + Y : INT; + END CASE; + END RECORD; + + SUBTYPE S_TRUE IS VAR_REC(TRUE); + SUBTYPE S_FALSE IS VAR_REC(FALSE); + + PROCEDURE CHECK(P : IN S_TRUE) IS + BEGIN + IF P.BOOL = FALSE THEN + FAILED("WRONG PROCEDURE ENTERED"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED INSIDE PROCEDURE"); + + END CHECK; + +BEGIN + TEST("C43104A", "CHECK THAT WITH THE TYPE OF THE AGGREGATE " & + "RESOLVED, THE DISCRIMINANT MAY BE USED TO " & + "DECIDE TO WHICH OF THE VARIANT'S SUBTYPES " & + "THE AGGREGATE BELONGS"); + + CHECK((TRUE, 1)); + + BEGIN + + CHECK((FALSE, 2)); + FAILED("PROCEDURE CALL USING '(FALSE, 2)' DID NOT RAISE " & + "EXCEPTION"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("INCORRECT EXCEPTION RAISED ON PROCEDURE CALL " & + "USING '(FALSE,2)'"); + END; + + RESULT; +END C43104A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43105a.ada b/gcc/testsuite/ada/acats/tests/c4/c43105a.ada new file mode 100644 index 000000000..28e9d280d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43105a.ada @@ -0,0 +1,97 @@ +-- C43105A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- IN A RECORD AGGREGATE, (X => E, Y => E), WHERE E IS AN OVERLOADED +-- ENUMERATION LITERAL, OVERLOADING RESOLUTION OCCURS SEPARATELY FOR +-- THE DIFFERENT OCCURRENCES OF E. + +-- HISTORY: +-- DHH 08/10/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43105A IS + +BEGIN + TEST("C43105A", "IN A RECORD AGGREGATE, (X => E, Y => E), WHERE " & + "E IS AN OVERLOADED ENUMERATION LITERAL, " & + "OVERLOADING RESOLUTION OCCURS SEPARATELY FOR " & + "THE DIFFERENT OCCURRENCES OF E"); + + DECLARE + TYPE COLOR IS (RED, YELLOW, GREEN); + TYPE PALETTE IS (GREEN, YELLOW, RED); + + TYPE REC IS + RECORD + X : COLOR; + Y : PALETTE; + END RECORD; + + TYPE RECD IS + RECORD + X : PALETTE; + Y : COLOR; + END RECORD; + + REC1 : REC; + REC2 : RECD; + + FUNCTION IDENT_C(C : COLOR) RETURN COLOR IS + BEGIN + IF EQUAL(3,3) THEN + RETURN C; + ELSE + RETURN GREEN; + END IF; + END IDENT_C; + + FUNCTION IDENT_P(P : PALETTE) RETURN PALETTE IS + BEGIN + IF EQUAL(3,3) THEN + RETURN P; + ELSE + RETURN RED; + END IF; + END IDENT_P; + + + BEGIN + REC1 := (X => YELLOW, Y => YELLOW); + REC2 := (X => YELLOW, Y => YELLOW); + + IF REC1.X /= IDENT_C(REC2.Y) THEN + FAILED("COLOR RESOLUTION FAILED"); + END IF; + + IF REC1.Y /= IDENT_P(REC2.X) THEN + FAILED("PALETTE RESOLUTION FAILED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED"); + END; + + RESULT; +END C43105A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43105b.ada b/gcc/testsuite/ada/acats/tests/c4/c43105b.ada new file mode 100644 index 000000000..6a7ea8171 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43105b.ada @@ -0,0 +1,94 @@ +-- C43105B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- IN A RECORD AGGREGATE (X => E, Y => E), WHERE E IS AN OVERLOADED +-- FUNCTION CALL, OVERLOADING RESOLUTION OCCURS SEPARATELY FOR THE +-- DIFFERENT OCCURRENCES OF E. + +-- HISTORY: +-- DHH 09/07/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43105B IS +BEGIN + TEST ("C43105B", "IN A RECORD AGGREGATE (X => E, Y => E), WHERE " & + "E IS AN OVERLOADED FUNCTION CALL, OVERLOADING " & + "RESOLUTION OCCURS SEPARATELY FOR THE " & + "DIFFERENT OCCURRENCES OF E"); + + DECLARE + TYPE COLOR IS (RED, YELLOW, GREEN); + TYPE PALETTE IS (GREEN, YELLOW, RED); + + TYPE REC IS + RECORD + X : COLOR; + Y : PALETTE; + END RECORD; + + TYPE RECD IS + RECORD + X : PALETTE; + Y : COLOR; + END RECORD; + + REC1 : REC; + REC2 : RECD; + + FUNCTION IDENT_C(C : COLOR) RETURN COLOR IS + BEGIN + IF EQUAL(3,3) THEN + RETURN C; + ELSE + RETURN GREEN; + END IF; + END IDENT_C; + + FUNCTION IDENT_C(P : PALETTE) RETURN PALETTE IS + BEGIN + IF EQUAL(3,3) THEN + RETURN P; + ELSE + RETURN RED; + END IF; + END IDENT_C; + + BEGIN + REC1 := (X => IDENT_C(YELLOW), Y => IDENT_C(YELLOW)); + REC2 := (X => IDENT_C(YELLOW), Y => IDENT_C(YELLOW)); + + IF REC1.X /= REC2.Y THEN + FAILED("COLOR FUNCTION RESOLUTION FAILED"); + END IF; + + IF REC1.Y /= REC2.X THEN + FAILED("PALETTE FUNCTION RESOLUTION FAILED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED"); + END; + RESULT; +END C43105B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43106a.ada b/gcc/testsuite/ada/acats/tests/c4/c43106a.ada new file mode 100644 index 000000000..64ac9503c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43106a.ada @@ -0,0 +1,90 @@ +-- C43106A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT BOTH NAMED AND POSITIONAL NOTATIONS ARE PERMITTED +-- WITHIN THE SAME RECORD AGGREGATE, (PROVIDED THAT ALL POSITIONAL +-- ASSOCIATIONS APPEAR BEFORE ANY NAMED ASSOCIATION). + +-- HISTORY: +-- DHH 08/10/88 CREATED ORIGIANL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43106A IS + + TYPE REC IS + RECORD + A : INTEGER; + B : CHARACTER; + C : BOOLEAN; + D, E, F, G : INTEGER; + H, I, J, K : CHARACTER; + L, M, N, O : BOOLEAN; + P, Q, R, S : STRING(1 .. 3); + T, U, V, W, X, Y, Z : BOOLEAN; + END RECORD; + AGG : REC := (12, 'A', TRUE, 1, 2, 3, 4, 'B', 'C', 'D', 'E', + P|R => "ABC", S|Q => "DEF", L|X|O|U => TRUE, + OTHERS => FALSE); + + FUNCTION IDENT_CHAR(X : CHARACTER) RETURN CHARACTER IS + BEGIN + IF EQUAL(3, 3) THEN + RETURN X; + ELSE + RETURN 'Z'; + END IF; + END IDENT_CHAR; + +BEGIN + TEST("C43106A", "CHECK THAT BOTH NAMED AND POSITIONAL NOTATIONS " & + "ARE PERMITTED WITHIN THE SAME RECORD " & + "AGGREGATE, (PROVIDED THAT ALL POSITIONAL " & + "ASSOCIATIONS APPEAR BEFORE ANY NAMED " & + "ASSOCIATION)"); + + IF NOT IDENT_BOOL(AGG.C) OR NOT IDENT_BOOL(AGG.L) OR + NOT IDENT_BOOL(AGG.X) OR NOT IDENT_BOOL(AGG.O) OR + NOT IDENT_BOOL(AGG.U) OR IDENT_BOOL(AGG.M) OR + IDENT_BOOL(AGG.N) OR IDENT_BOOL(AGG.T) OR + IDENT_BOOL(AGG.V) OR IDENT_BOOL(AGG.W) OR + IDENT_BOOL(AGG.Y) OR IDENT_BOOL(AGG.Z) THEN + FAILED("BOOLEANS NOT INITIALIZED TO AGGREGATE VALUES"); + END IF; + + IF IDENT_STR(AGG.P) /= IDENT_STR(AGG.R) OR + IDENT_STR(AGG.Q) /= IDENT_STR(AGG.S) THEN + FAILED("STRINGS NOT INITIALIZED CORRECTLY"); + END IF; + + IF IDENT_CHAR(AGG.B) /= IDENT_CHAR('A') OR + IDENT_CHAR(AGG.H) /= IDENT_CHAR('B') OR + IDENT_CHAR(AGG.I) /= IDENT_CHAR('C') OR + IDENT_CHAR(AGG.J) /= IDENT_CHAR('D') OR + IDENT_CHAR(AGG.K) /= IDENT_CHAR('E') THEN + FAILED("CHARACTERS NOT INITIALIZED CORRECTLY"); + END IF; + + RESULT; +END C43106A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43107a.ada b/gcc/testsuite/ada/acats/tests/c4/c43107a.ada new file mode 100644 index 000000000..5fcc1a273 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43107a.ada @@ -0,0 +1,125 @@ +-- C43107A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT AN EXPRESSION ASSOCIATED WITH MORE THAN ONE RECORD +-- COMPONENT IS EVALUATED ONCE FOR EACH ASSOCIATED COMPONENT. + +-- EG 02/14/84 + +WITH REPORT; + +PROCEDURE C43107A IS + + USE REPORT; + +BEGIN + + TEST("C43107A","CHECK THAT AN EXPRESSION WITH MORE THAN ONE " & + "RECORD COMPONENT IS EVALUATED ONCE FOR EACH " & + "ASSOCIATED COMPONENT"); + + BEGIN + +CASE_A : DECLARE + + TYPE T1 IS ARRAY(1 .. 2) OF INTEGER; + TYPE R1 IS + RECORD + A : T1; + B : INTEGER; + C : T1; + D : INTEGER; + E : INTEGER; + END RECORD; + + A1 : R1; + CNTR : INTEGER := 0; + + FUNCTION FUN1 (A : T1) RETURN T1 IS + BEGIN + CNTR := IDENT_INT(CNTR+1); + RETURN A; + END FUN1; + + FUNCTION FUN2 (A : INTEGER) RETURN INTEGER IS + BEGIN + CNTR := CNTR+1; + RETURN IDENT_INT(A); + END FUN2; + + BEGIN + + A1 := (A | C => FUN1((-1, -2)), OTHERS => FUN2(-3)+1); + IF CNTR /= 5 THEN + FAILED ("CASE A : INCORRECT NUMBER OF EVALUATIONS" & + " OF RECORD ASSOCIATED COMPONENTS"); + END IF; + IF A1.A /= (-1, -2) OR A1.C /= (-1, -2) OR + A1.B /= -2 OR A1.D /= -2 OR A1.E /= -2 THEN + FAILED ("CASE A : INCORRECT VALUES IN RECORD"); + END IF; + + END CASE_A; + +CASE_B : DECLARE + + TYPE T2 IS ACCESS INTEGER; + TYPE R2 IS + RECORD + A : T2; + B : INTEGER; + C : T2; + D : INTEGER; + E : INTEGER; + END RECORD; + + B1 : R2; + CNTR : INTEGER := 0; + + FUNCTION FUN3 RETURN INTEGER IS + BEGIN + CNTR := CNTR+1; + RETURN IDENT_INT(2); + END FUN3; + + BEGIN + + B1 := (A | C => NEW INTEGER'(-1), + B | D | E => FUN3); + IF B1.A = B1.C OR CNTR /= 3 THEN + FAILED ("CASE B : INCORRECT NUMBER OF EVALUATION" & + " OF RECORD ASSOCIATED COMPONENTS"); + END IF; + IF B1.B /= 2 OR B1.D /= 2 OR B1.E /= 2 OR + B1.A = NULL OR B1.C = NULL OR B1.A = B1.C THEN + FAILED ("CASE B : INCORRECT VALUES IN RECORD"); + END IF; + + END CASE_B; + + END; + + RESULT; + +END C43107A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43108a.ada b/gcc/testsuite/ada/acats/tests/c4/c43108a.ada new file mode 100644 index 000000000..24c140f67 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43108a.ada @@ -0,0 +1,111 @@ +-- C43108A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT IN A RECORD AGGREGATE THE VALUE OF A DISCRIMINANT IS +-- USED TO RESOLVE THE TYPE OF A COMPONENT THAT DEPENDS ON THE +-- DISCRIMINANT. + +-- HISTORY: +-- DHH 09/08/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43108A IS + +BEGIN + TEST ("C43108A", "CHECK THAT IN A RECORD AGGREGATE THE VALUE OF " & + "A DISCRIMINANT IS USED TO RESOLVE THE TYPE OF " & + "A COMPONENT THAT DEPENDS ON THE DISCRIMINANT"); + + DECLARE + A : INTEGER; + + TYPE DIS(A : BOOLEAN) IS + RECORD + CASE A IS + WHEN TRUE => + B : BOOLEAN; + C : INTEGER; + WHEN FALSE => + D : INTEGER; + END CASE; + END RECORD; + + FUNCTION DIFF(PARAM : DIS) RETURN INTEGER IS + BEGIN + IF PARAM.B THEN + RETURN PARAM.C; + ELSE + RETURN PARAM.D; + END IF; + END DIFF; + + BEGIN + A := DIFF((C => 3, OTHERS => TRUE)); + + IF A /= IDENT_INT(3) THEN + FAILED("STATIC OTHERS NOT DECIDED CORRECTLY"); + END IF; + END; + + DECLARE + GLOBAL : INTEGER := 0; + TYPE INT IS NEW INTEGER; + + TYPE DIS(A : BOOLEAN) IS + RECORD + CASE A IS + WHEN TRUE => + I1 : INT; + WHEN FALSE => + I2 : INTEGER; + END CASE; + END RECORD; + FUNCTION F RETURN INT; + FUNCTION F RETURN INTEGER; + + A : DIS(TRUE); + + FUNCTION F RETURN INT IS + BEGIN + GLOBAL := 1; + RETURN 5; + END F; + + FUNCTION F RETURN INTEGER IS + BEGIN + GLOBAL := 2; + RETURN 5; + END F; + + BEGIN + A := (TRUE, OTHERS => F); + + IF GLOBAL /= 1 THEN + FAILED("NON_STATIC OTHERS NOT DECIDED CORRECTLY"); + END IF; + END; + + RESULT; +END C43108A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c432001.a b/gcc/testsuite/ada/acats/tests/c4/c432001.a new file mode 100644 index 000000000..dab75b388 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c432001.a @@ -0,0 +1,512 @@ +-- C432001.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 extension aggregates may be used to specify values +-- for types that are record extensions. Check that the +-- type of the ancestor expression may be any nonlimited type that +-- is a record extension, including private types and private +-- extensions. Check that the type for the aggregate is +-- derived from the type of the ancestor expression. +-- +-- TEST DESCRIPTION: +-- +-- Two progenitor nonlimited record types are declared, one +-- nonprivate and one private. Using these as parent types, +-- all possible combinations of record extensions are declared +-- (Nonprivate record extension of nonprivate type, private +-- extension of nonprivate type, nonprivate record extension of +-- private type, and private extension of private type). Finally, +-- each of these types is extended using nonprivate record +-- extensions. +-- +-- Extension of private types is done in packages other than +-- the ones containing the parent declaration. This is done +-- to eliminate errors with extension of the partial view of +-- a type, which is not an objective of this test. +-- +-- All components of private types and private extensions are given +-- default values. This eliminates the need for separate subprograms +-- whose sole purpose is to place a value into a private record type. +-- +-- Types that have been extended are checked using an object of their +-- parent type as the ancestor expression. For those types that +-- have been extended twice, using only nonprivate record extensions, +-- a check is made using an object of their grandparent type as +-- the ancestor expression. +-- +-- For each type, a subprogram is defined which checks the contents +-- of the parameter, which is a value of the record extension. +-- Components of nonprivate record extensions are checked against +-- passed-in parameters of the component type. Components of private +-- extensions are checked to ensure that they maintain their initial +-- values. +-- +-- To check that the aggregate's type is derived from its ancestor, +-- each Check subprogram in turn calls the Check subprogram for +-- its parent type. Explicit conversion is used to convert the +-- record extension to the parent type. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +package C432001_0 is + + type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic); + + type N is tagged record + How_Long_Ago : Natural := Report.Ident_Int(1); + Era : Eras := Cenozoic; + end record; + + function Check (Rec : in N; + N : in Natural; + E : in Eras) return Boolean; + + type P is tagged private; + + function Check (Rec : in P) return Boolean; + +private + + type P is tagged record + How_Long_Ago : Natural := Report.Ident_Int(150); + Era : Eras := Mesozoic; + end record; + +end C432001_0; + +package body C432001_0 is + + function Check (Rec : in P) return Boolean is + begin + return Rec.How_Long_Ago = 150 and Rec.Era = Mesozoic; + end Check; + + function Check (Rec : in N; + N : in Natural; + E : in Eras) return Boolean is + begin + return Rec.How_Long_Ago = N and Rec.Era = E; + end Check; + +end C432001_0; + +with C432001_0; +package C432001_1 is + + type Periods is + (Aphebian, Helikian, Hadrynian, + Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian, + Triassic, Jurassic, Cretaceous, + Tertiary, Quaternary); + + type N_N is new C432001_0.N with record + Period : Periods := C432001_1.Quaternary; + end record; + + function Check (Rec : in N_N; + N : in Natural; + E : in C432001_0.Eras; + P : in Periods) return Boolean; + + type N_P is new C432001_0.N with private; + + function Check (Rec : in N_P) return Boolean; + + type P_N is new C432001_0.P with record + Period : Periods := C432001_1.Jurassic; + end record; + + function Check (Rec : in P_N; + P : in Periods) return Boolean; + + type P_P is new C432001_0.P with private; + + function Check (Rec : in P_P) return Boolean; + + type P_P_Null is new C432001_0.P with null record; + +private + + type N_P is new C432001_0.N with record + Period : Periods := C432001_1.Quaternary; + end record; + + type P_P is new C432001_0.P with record + Period : Periods := C432001_1.Jurassic; + end record; + +end C432001_1; + +with Report; +package body C432001_1 is + + function Check (Rec : in N_N; + N : in Natural; + E : in C432001_0.Eras; + P : in Periods) return Boolean is + begin + if not C432001_0.Check (C432001_0.N (Rec), N, E) then + Report.Failed ("Conversion to parent type of " & + "nonprivate portion of " & + "nonprivate extension failed"); + end if; + return Rec.Period = P; + end Check; + + + function Check (Rec : in N_P) return Boolean is + begin + if not C432001_0.Check (C432001_0.N (Rec), 1, C432001_0.Cenozoic) then + Report.Failed ("Conversion to parent type of " & + "nonprivate portion of " & + "private extension failed"); + end if; + return Rec.Period = C432001_1.Quaternary; + end Check; + + function Check (Rec : in P_N; + P : in Periods) return Boolean is + begin + if not C432001_0.Check (C432001_0.P (Rec)) then + Report.Failed ("Conversion to parent type of " & + "private portion of " & + "nonprivate extension failed"); + end if; + return Rec.Period = P; + end Check; + + function Check (Rec : in P_P) return Boolean is + begin + if not C432001_0.Check (C432001_0.P (Rec)) then + Report.Failed ("Conversion to parent type of " & + "private portion of " & + "private extension failed"); + end if; + return Rec.Period = C432001_1.Jurassic; + end Check; + +end C432001_1; + +with C432001_0; +with C432001_1; +package C432001_2 is + + -- All types herein are nonprivate extensions, since aggregates + -- cannot be given for private extensions + + type N_N_N is new C432001_1.N_N with record + Sample_On_Loan : Boolean; + end record; + + function Check (Rec : in N_N_N; + N : in Natural; + E : in C432001_0.Eras; + P : in C432001_1.Periods; + B : in Boolean) return Boolean; + + type N_P_N is new C432001_1.N_P with record + Sample_On_Loan : Boolean; + end record; + + function Check (Rec : in N_P_N; + B : Boolean) return Boolean; + + type P_N_N is new C432001_1.P_N with record + Sample_On_Loan : Boolean; + end record; + + function Check (Rec : in P_N_N; + P : in C432001_1.Periods; + B : Boolean) return Boolean; + + type P_P_N is new C432001_1.P_P with record + Sample_On_Loan : Boolean; + end record; + + function Check (Rec : in P_P_N; + B : Boolean) return Boolean; + +end C432001_2; + +with Report; +package body C432001_2 is + + -- direct access to operator + use type C432001_1.Periods; + + + function Check (Rec : in N_N_N; + N : in Natural; + E : in C432001_0.Eras; + P : in C432001_1.Periods; + B : in Boolean) return Boolean is + begin + if not C432001_1.Check (C432001_1.N_N (Rec), N, E, P) then + Report.Failed ("Conversion to parent " & + "nonprivate type extension " & + "failed"); + end if; + return Rec.Sample_On_Loan = B; + end Check; + + + function Check (Rec : in N_P_N; + B : Boolean) return Boolean is + begin + if not C432001_1.Check (C432001_1.N_P (Rec)) then + Report.Failed ("Conversion to parent " & + "private type extension " & + "failed"); + end if; + return Rec.Sample_On_Loan = B; + end Check; + + function Check (Rec : in P_N_N; + P : in C432001_1.Periods; + B : Boolean) return Boolean is + begin + if not C432001_1.Check (C432001_1.P_N (Rec), P) then + Report.Failed ("Conversion to parent " & + "nonprivate type extension " & + "failed"); + end if; + return Rec.Sample_On_Loan = B; + end Check; + + function Check (Rec : in P_P_N; + B : Boolean) return Boolean is + begin + if not C432001_1.Check (C432001_1.P_P (Rec)) then + Report.Failed ("Conversion to parent " & + "private type extension " & + "failed"); + end if; + return Rec.Sample_On_Loan = B; + end Check; + +end C432001_2; + + +with C432001_0; +with C432001_1; +with C432001_2; +with Report; +procedure C432001 is + + N_Object : C432001_0.N := (How_Long_Ago => Report.Ident_Int(375), + Era => C432001_0.Paleozoic); + + P_Object : C432001_0.P; -- default value is (150, + -- C432001_0.Mesozoic) + + N_N_Object : C432001_1.N_N := + (N_Object with Period => C432001_1.Devonian); + + P_N_Object : C432001_1.P_N := + (P_Object with Period => C432001_1.Jurassic); + + N_P_Object : C432001_1.N_P; -- default is (1, + -- C432001_0.Cenozoic, + -- C432001_1.Quaternary) + + P_P_Object : C432001_1.P_P; -- default is (150, + -- C432001_0.Mesozoic, + -- C432001_1.Jurassic) + + P_P_Null_Ob:C432001_1.P_P_Null := (P_Object with null record); + + N_N_N_Object : C432001_2.N_N_N := + (N_N_Object with Sample_On_Loan => Report.Ident_Bool(True)); + + N_P_N_Object : C432001_2.N_P_N := + (N_P_Object with Sample_On_Loan => Report.Ident_Bool(False)); + + P_N_N_Object : C432001_2.P_N_N := + (P_N_Object with Sample_On_Loan => Report.Ident_Bool(True)); + + P_P_N_Object : C432001_2.P_P_N := + (P_P_Object with Sample_On_Loan => Report.Ident_Bool(False)); + + P_N_Object_2 : C432001_1.P_N := (C432001_0.P(P_N_N_Object) + with C432001_1.Carboniferous); + + N_N_Object_2 : C432001_1.N_N := (C432001_0.N'(42,C432001_0.Precambrian) + with C432001_1.Carboniferous); + +begin + + Report.Test ("C432001", "Extension aggregates"); + + -- check ultimate ancestor types + + if not C432001_0.Check (N_Object, + 375, + C432001_0.Paleozoic) then + Report.Failed ("Object of " & + "nonprivate type " & + "failed content check"); + end if; + + if not C432001_0.Check (P_Object) then + Report.Failed ("Object of " & + "private type " & + "failed content check"); + end if; + + -- check direct type extensions + + if not C432001_1.Check (N_N_Object, + 375, + C432001_0.Paleozoic, + C432001_1.Devonian) then + Report.Failed ("Object of " & + "nonprivate extension of nonprivate type " & + "failed content check"); + end if; + + if not C432001_1.Check (N_P_Object) then + Report.Failed ("Object of " & + "private extension of nonprivate type " & + "failed content check"); + end if; + + if not C432001_1.Check (P_N_Object, + C432001_1.Jurassic) then + Report.Failed ("Object of " & + "nonprivate extension of private type " & + "failed content check"); + end if; + + if not C432001_1.Check (P_P_Object) then + Report.Failed ("Object of " & + "private extension of private type " & + "failed content check"); + end if; + + if not C432001_1.Check (P_P_Null_Ob) then + Report.Failed ("Object of " & + "private type " & + "failed content check"); + end if; + + + -- check direct extensions of extensions + + if not C432001_2.Check (N_N_N_Object, + 375, + C432001_0.Paleozoic, + C432001_1.Devonian, + True) then + Report.Failed ("Object of " & + "nonprivate extension of nonprivate extension " & + "(of nonprivate parent) " & + "failed content check"); + end if; + + if not C432001_2.Check (N_P_N_Object, False) then + Report.Failed ("Object of " & + "nonprivate extension of private extension " & + "(of nonprivate parent) " & + "failed content check"); + end if; + + if not C432001_2.Check (P_N_N_Object, + C432001_1.Jurassic, + True) then + Report.Failed ("Object of " & + "nonprivate extension of nonprivate extension " & + "(of private parent) " & + "failed content check"); + end if; + + if not C432001_2.Check (P_P_N_Object, False) then + Report.Failed ("Object of " & + "nonprivate extension of private extension " & + "(of private parent) " & + "failed content check"); + end if; + + -- check that the extension aggregate may specify an expression of + -- a "grandparent" ancestor type + + -- types tested are derived through nonprivate extensions only + -- (extension aggregates are not allowed if the path from the + -- ancestor type wanders through a private extension) + + N_N_N_Object := + (N_Object with Period => C432001_1.Devonian, + Sample_On_Loan => Report.Ident_Bool(True)); + + if not C432001_2.Check (N_N_N_Object, + 375, + C432001_0.Paleozoic, + C432001_1.Devonian, + True) then + Report.Failed ("Object of " & + "nonprivate extension " & + "of nonprivate ancestor " & + "failed content check"); + end if; + + P_N_N_Object := + (P_Object with Period => C432001_1.Jurassic, + Sample_On_Loan => Report.Ident_Bool(True)); + + if not C432001_2.Check (P_N_N_Object, + C432001_1.Jurassic, + True) then + Report.Failed ("Object of " & + "nonprivate extension " & + "of private ancestor " & + "failed content check"); + end if; + + -- Check additional cases + if not C432001_1.Check (P_N_Object_2, + C432001_1.Carboniferous) then + Report.Failed ("Additional Object of " & + "nonprivate extension of private type " & + "failed content check"); + end if; + + if not C432001_1.Check (N_N_Object_2, + 42, + C432001_0.Precambrian, + C432001_1.Carboniferous) then + Report.Failed ("Additional Object of " & + "nonprivate extension of nonprivate type " & + "failed content check"); + end if; + + Report.Result; + +end C432001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c432002.a b/gcc/testsuite/ada/acats/tests/c4/c432002.a new file mode 100644 index 000000000..5de821b30 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c432002.a @@ -0,0 +1,764 @@ +-- C432002.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 if an extension aggregate specifies a value for a record +-- extension and the ancestor expression has discriminants that are +-- inherited by the record extension, then a check is made that each +-- discriminant has the value specified. +-- +-- Check that if an extension aggregate specifies a value for a record +-- extension and the ancestor expression has discriminants that are not +-- inherited by the record extension, then a check is made that each +-- such discriminant has the value specified for the corresponding +-- discriminant. +-- +-- Check that the corresponding discriminant value may be specified +-- in the record component association list or in the derived type +-- definition for an ancestor. +-- +-- Check the case of ancestors that are several generations removed. +-- Check the case where the value of the discriminant(s) in question +-- is supplied several generations removed. +-- +-- Check the case of multiple discriminants. +-- +-- Check that Constraint_Error is raised if the check fails. +-- +-- TEST DESCRIPTION: +-- A hierarchy of tagged types is declared from a discriminated +-- root type. Each level declares two kinds of types: (1) a type +-- extension which constrains the discriminant of its parent to +-- the value of an expression and (2) a type extension that +-- constrains the discriminant of its parent to equal a new discriminant +-- of the type extension (These are the two categories of noninherited +-- discriminants). +-- +-- Values for each type are declared within nested blocks. This is +-- done so that the instances that produce Constraint_Error may +-- be dealt with cleanly without forcing the program to exit. +-- +-- Success and failure cases (which should raise Constraint_Error) +-- are set up for each kind of type. Additionally, for the first +-- level of the hierarchy, separate tests are done for ancestor +-- expressions specified by aggregates and those specified by +-- variables. Later tests are performed using variables only. +-- +-- Additionally, the cases tested consist of the following kinds of +-- types: +-- +-- Extensions of extensions, using both the parent and grandparent +-- types for the ancestor expression, +-- +-- Ancestor expressions which are several generations removed +-- from the type of the aggregate, +-- +-- Extensions of types with multiple discriminants, where the +-- extension declares a new discriminant which corresponds to +-- more than one discriminant of the ancestor types. +-- +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Removed RM references from objective text. +-- 20 Dec 94 SAIC Repair confusion WRT overridden discriminants +-- +--! + +package C432002_0 is + + subtype Length is Natural range 0..256; + type Discriminant (L : Length) is tagged + record + S1 : String (1..L); + end record; + + procedure Do_Something (Rec : in out Discriminant); + -- inherited by all type extensions + + -- Aggregates of Discriminant are of the form + -- (L, S1) where L= S1'Length + + -- Discriminant of parent constrained to value of an expression + type Constrained_Discriminant_Extension is + new Discriminant (L => 10) + with record + S2 : String (1..20); + end record; + + -- Aggregates of Constrained_Discriminant_Extension are of the form + -- (L, S1, S2), where L = S1'Length = 10, S2'Length = 20 + + type Once_Removed is new Constrained_Discriminant_Extension + with record + S3 : String (1..3); + end record; + + type Twice_Removed is new Once_Removed + with record + S4 : String (1..8); + end record; + + -- Aggregates of Twice_Removed are of the form + -- (L, S1, S2, S3, S4), where L = S1'Length = 10, + -- S2'Length = 20, + -- S3'Length = 3, + -- S4'Length = 8 + + -- Discriminant of parent constrained to equal new discriminant + type New_Discriminant_Extension (N : Length) is + new Discriminant (L => N) with + record + S2 : String (1..N); + end record; + + -- Aggregates of New_Discriminant_Extension are of the form + -- (N, S1, S2), where N = S1'Length = S2'Length + + -- Discriminant of parent extension constrained to the value of + -- an expression + type Constrained_Extension_Extension is + new New_Discriminant_Extension (N => 20) + with record + S3 : String (1..5); + end record; + + -- Aggregates of Constrained_Extension_Extension are of the form + -- (N, S1, S2, S3), where N = S1'Length = S2'Length = 20, + -- S3'Length = 5 + + -- Discriminant of parent extension constrained to equal a new + -- discriminant + type New_Extension_Extension (I : Length) is + new New_Discriminant_Extension (N => I) + with record + S3 : String (1..I); + end record; + + -- Aggregates of New_Extension_Extension are of the form + -- (I, S1, 2, S3), where + -- I = S1'Length = S2'Length = S3'Length + + type Multiple_Discriminants (A, B : Length) is tagged + record + S1 : String (1..A); + S2 : String (1..B); + end record; + + procedure Do_Something (Rec : in out Multiple_Discriminants); + -- inherited by type extension + + -- Aggregates of Multiple_Discriminants are of the form + -- (A, B, S1, S2), where A = S1'Length, B = S2'Length + + type Multiple_Discriminant_Extension (C : Length) is + new Multiple_Discriminants (A => C, B => C) + with record + S3 : String (1..C); + end record; + + -- Aggregates of Multiple_Discriminant_Extension are of the form + -- (A, B, S1, S2, C, S3), where + -- A = B = C = S1'Length = S2'Length = S3'Length + +end C432002_0; + +with Report; +package body C432002_0 is + + S : String (1..20) := "12345678901234567890"; + + procedure Do_Something (Rec : in out Discriminant) is + begin + Rec.S1 := Report.Ident_Str (S (1..Rec.L)); + end Do_Something; + + procedure Do_Something (Rec : in out Multiple_Discriminants) is + begin + Rec.S1 := Report.Ident_Str (S (1..Rec.A)); + end Do_Something; + +end C432002_0; + + +with C432002_0; +with Report; +procedure C432002 is + + -- Various different-sized strings for variety + String_3 : String (1..3) := Report.Ident_Str("123"); + String_5 : String (1..5) := Report.Ident_Str("12345"); + String_8 : String (1..8) := Report.Ident_Str("12345678"); + String_10 : String (1..10) := Report.Ident_Str("1234567890"); + String_11 : String (1..11) := Report.Ident_Str("12345678901"); + String_20 : String (1..20) := Report.Ident_Str("12345678901234567890"); + +begin + + Report.Test ("C432002", + "Extension aggregates for discriminated types"); + + -------------------------------------------------------------------- + -- Extension constrains parent's discriminant to value of expression + -------------------------------------------------------------------- + + -- Successful cases - value matches corresponding discriminant value + + CD_Matched_Aggregate: + begin + declare + CD : C432002_0.Constrained_Discriminant_Extension := + (C432002_0.Discriminant'(L => 10, + S1 => String_10) + with S2 => String_20); + begin + C432002_0.Do_Something(CD); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension " & + "with discriminant constrained: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end CD_Matched_Aggregate; + + CD_Matched_Variable: + begin + declare + D : C432002_0.Discriminant(L => 10) := + C432002_0.Discriminant'(L => 10, + S1 => String_10); + + CD : C432002_0.Constrained_Discriminant_Extension := + (D with S2 => String_20); + begin + C432002_0.Do_Something(CD); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is a variable"); + Report.Failed ("Aggregate of extension " & + "with discriminant constrained: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end CD_Matched_Variable; + + + -- Unsuccessful cases - value does not match value of corresponding + -- discriminant. Constraint_Error should be + -- raised. + + CD_Unmatched_Aggregate: + begin + declare + CD : C432002_0.Constrained_Discriminant_Extension := + (C432002_0.Discriminant'(L => 5, + S1 => String_5) + with S2 => String_20); + begin + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension " & + "with discriminant constrained: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(CD); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise of Constraint_Error is expected + end CD_Unmatched_Aggregate; + + CD_Unmatched_Variable: + begin + declare + D : C432002_0.Discriminant(L => 5) := + C432002_0.Discriminant'(L => 5, + S1 => String_5); + + CD : C432002_0.Constrained_Discriminant_Extension := + (D with S2 => String_20); + begin + Report.Comment ("Ancestor expression is an variable"); + Report.Failed ("Aggregate of extension " & + "with discriminant constrained: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(CD); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise of Constraint_Error is expected + end CD_Unmatched_Variable; + + ----------------------------------------------------------------------- + -- Extension constrains parent's discriminant to equal new discriminant + ----------------------------------------------------------------------- + + -- Successful cases - value matches corresponding discriminant value + + ND_Matched_Aggregate: + begin + declare + ND : C432002_0.New_Discriminant_Extension (N => 8) := + (C432002_0.Discriminant'(L => 8, + S1 => String_8) + with N => 8, + S2 => String_8); + begin + C432002_0.Do_Something(ND); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension " & + "with new discriminant: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end ND_Matched_Aggregate; + + ND_Matched_Variable: + begin + declare + D : C432002_0.Discriminant(L => 3) := + C432002_0.Discriminant'(L => 3, + S1 => String_3); + + ND : C432002_0.New_Discriminant_Extension (N => 3) := + (D with N => 3, + S2 => String_3); + begin + C432002_0.Do_Something(ND); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is an variable"); + Report.Failed ("Aggregate of extension " & + "with new discriminant: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end ND_Matched_Variable; + + + -- Unsuccessful cases - value does not match value of corresponding + -- discriminant. Constraint_Error should be + -- raised. + + ND_Unmatched_Aggregate: + begin + declare + ND : C432002_0.New_Discriminant_Extension (N => 20) := + (C432002_0.Discriminant'(L => 11, + S1 => String_11) + with N => 20, + S2 => String_20); + begin + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension " & + "with new discriminant: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(ND); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise is expected + end ND_Unmatched_Aggregate; + + ND_Unmatched_Variable: + begin + declare + D : C432002_0.Discriminant(L => 5) := + C432002_0.Discriminant'(L => 5, + S1 => String_5); + + ND : C432002_0.New_Discriminant_Extension (N => 20) := + (D with N => 20, + S2 => String_20); + begin + Report.Comment ("Ancestor expression is an variable"); + Report.Failed ("Aggregate of extension " & + "with new discriminant: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(ND); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise is expected + end ND_Unmatched_Variable; + + -------------------------------------------------------------------- + -- Extension constrains parent's discriminant to value of expression + -- Parent is a discriminant extension + -------------------------------------------------------------------- + + -- Successful cases - value matches corresponding discriminant value + + CE_Matched_Aggregate: + begin + declare + CE : C432002_0.Constrained_Extension_Extension := + (C432002_0.Discriminant'(L => 20, + S1 => String_20) + with N => 20, + S2 => String_20, + S3 => String_5); + begin + C432002_0.Do_Something(CE); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension (of extension) " & + "with discriminant constrained: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end CE_Matched_Aggregate; + + CE_Matched_Variable: + begin + declare + ND : C432002_0.New_Discriminant_Extension (N => 20) := + C432002_0.New_Discriminant_Extension' + (N => 20, + S1 => String_20, + S2 => String_20); + + CE : C432002_0.Constrained_Extension_Extension := + (ND with S3 => String_5); + begin + C432002_0.Do_Something(CE); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is a variable"); + Report.Failed ("Aggregate of extension (of extension) " & + "with discriminant constrained: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end CE_Matched_Variable; + + + -- Unsuccessful cases - value does not match value of corresponding + -- discriminant. Constraint_Error should be + -- raised. + + CE_Unmatched_Aggregate: + begin + declare + CE : C432002_0.Constrained_Extension_Extension := + (C432002_0.New_Discriminant_Extension' + (N => 11, + S1 => String_11, + S2 => String_11) + with S3 => String_5); + begin + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension (of extension) " & + "Constraint_Error was not raised " & + "with discriminant constrained: " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(CE); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise of Constraint_Error is expected + end CE_Unmatched_Aggregate; + + CE_Unmatched_Variable: + begin + declare + D : C432002_0.Discriminant(L => 8) := + C432002_0.Discriminant'(L => 8, + S1 => String_8); + + CE : C432002_0.Constrained_Extension_Extension := + (D with N => 8, + S2 => String_8, + S3 => String_5); + begin + Report.Comment ("Ancestor expression is a variable"); + Report.Failed ("Aggregate of extension (of extension) " & + "with discriminant constrained: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(CE); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise of Constraint_Error is expected + end CE_Unmatched_Variable; + + ----------------------------------------------------------------------- + -- Extension constrains parent's discriminant to equal new discriminant + -- Parent is a discriminant extension + ----------------------------------------------------------------------- + + -- Successful cases - value matches corresponding discriminant value + + NE_Matched_Aggregate: + begin + declare + NE : C432002_0.New_Extension_Extension (I => 8) := + (C432002_0.Discriminant'(L => 8, + S1 => String_8) + with I => 8, + S2 => String_8, + S3 => String_8); + begin + C432002_0.Do_Something(NE); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension (of extension) " & + "with new discriminant: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end NE_Matched_Aggregate; + + NE_Matched_Variable: + begin + declare + ND : C432002_0.New_Discriminant_Extension (N => 3) := + C432002_0.New_Discriminant_Extension' + (N => 3, + S1 => String_3, + S2 => String_3); + + NE : C432002_0.New_Extension_Extension (I => 3) := + (ND with I => 3, + S3 => String_3); + begin + C432002_0.Do_Something(NE); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is a variable"); + Report.Failed ("Aggregate of extension (of extension) " & + "with new discriminant: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end NE_Matched_Variable; + + + -- Unsuccessful cases - value does not match value of corresponding + -- discriminant. Constraint_Error should be + -- raised. + + NE_Unmatched_Aggregate: + begin + declare + NE : C432002_0.New_Extension_Extension (I => 8) := + (C432002_0.New_Discriminant_Extension' + (C432002_0.Discriminant'(L => 11, + S1 => String_11) + with N => 11, + S2 => String_11) + with I => 8, + S3 => String_8); + begin + Report.Comment ("Ancestor expression is an extension aggregate"); + Report.Failed ("Aggregate of extension (of extension) " & + "with new discriminant: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(NE); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise is expected + end NE_Unmatched_Aggregate; + + NE_Unmatched_Variable: + begin + declare + D : C432002_0.Discriminant(L => 5) := + C432002_0.Discriminant'(L => 5, + S1 => String_5); + + NE : C432002_0.New_Extension_Extension (I => 20) := + (D with I => 5, + S2 => String_5, + S3 => String_20); + begin + Report.Comment ("Ancestor expression is a variable"); + Report.Failed ("Aggregate of extension (of extension) " & + "with new discriminant: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(NE); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise is expected + end NE_Unmatched_Variable; + + ----------------------------------------------------------------------- + -- Corresponding discriminant is two levels deeper than aggregate + ----------------------------------------------------------------------- + + -- Successful case - value matches corresponding discriminant value + + TR_Matched_Variable: + begin + declare + D : C432002_0.Discriminant (L => 10) := + C432002_0.Discriminant'(L => 10, + S1 => String_10); + + TR : C432002_0.Twice_Removed := + C432002_0.Twice_Removed'(D with S2 => String_20, + S3 => String_3, + S4 => String_8); + -- N is constrained to a value in the derived_type_definition + -- of Constrained_Discriminant_Extension. Its omission from + -- the above record_component_association_list is allowed by + -- 4.3.2(6). + + begin + C432002_0.Do_Something(TR); -- success + end; + exception + when Constraint_Error => + Report.Failed ("Aggregate of far-removed extension " & + "with discriminant constrained: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end TR_Matched_Variable; + + + -- Unsuccessful case - value does not match value of corresponding + -- discriminant. Constraint_Error should be + -- raised. + + TR_Unmatched_Variable: + begin + declare + D : C432002_0.Discriminant (L => 5) := + C432002_0.Discriminant'(L => 5, + S1 => String_5); + + TR : C432002_0.Twice_Removed := + C432002_0.Twice_Removed'(D with S2 => String_20, + S3 => String_3, + S4 => String_8); + + begin + Report.Failed ("Aggregate of far-removed extension " & + "with discriminant constrained: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(TR); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise is expected + end TR_Unmatched_Variable; + + ------------------------------------------------------------------------ + -- Parent has multiple discriminants. + -- Discriminant in extension corresponds to both parental discriminants. + ------------------------------------------------------------------------ + + -- Successful case - value matches corresponding discriminant value + + MD_Matched_Variable: + begin + declare + MD : C432002_0.Multiple_Discriminants (A => 10, B => 10) := + C432002_0.Multiple_Discriminants'(A => 10, + B => 10, + S1 => String_10, + S2 => String_10); + MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) := + (MD with C => 10, + S3 => String_10); + + begin + C432002_0.Do_Something(MDE); -- success + end; + exception + when Constraint_Error => + Report.Failed ("Aggregate of extension " & + "of multiply-discriminated parent: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end MD_Matched_Variable; + + + -- Unsuccessful case - value does not match value of corresponding + -- discriminant. Constraint_Error should be + -- raised. + + MD_Unmatched_Variable: + begin + declare + MD : C432002_0.Multiple_Discriminants (A => 10, B => 8) := + C432002_0.Multiple_Discriminants'(A => 10, + B => 8, + S1 => String_10, + S2 => String_8); + MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) := + (MD with C => 10, + S3 => String_10); + + begin + Report.Failed ("Aggregate of extension " & + "of multiply-discriminated parent: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(MDE); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise is expected + end MD_Unmatched_Variable; + + Report.Result; + +end C432002; diff --git a/gcc/testsuite/ada/acats/tests/c4/c432003.a b/gcc/testsuite/ada/acats/tests/c4/c432003.a new file mode 100644 index 000000000..8988992c4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c432003.a @@ -0,0 +1,594 @@ +-- C432003.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 if the type of the ancestor part of an extension aggregate +-- has discriminants that are not inherited by the type of the aggregate, +-- and the ancestor part is a subtype mark that denotes a constrained +-- subtype, Constraint_Error is raised if: 1) any discriminant of the +-- ancestor has a different value than that specified for a corresponding +-- discriminant in the derived type definition for some ancestor of the +-- type of the aggregate, or 2) the value for the discriminant in the +-- record association list is not the value of the corresponding +-- discriminant. Check that the components of the value of the +-- aggregate not given by the record component association list are +-- initialized by default as for an object of the ancestor type. +-- +-- TEST DESCRIPTION: +-- Consider: +-- +-- type T (D1: ...) is tagged ... +-- +-- type DT is new T with ... +-- subtype ST is DT (D1 => 3); -- Constrained subtype. +-- +-- type NT1 (D2: ...) is new DT (D1 => D2) with null record; +-- type NT2 (D2: ...) is new DT (D1 => 6) with null record; +-- type NT3 is new DT (D1 => 6) with null record; +-- +-- A: NT1 := (T with D2 => 6); -- OK: T is unconstrained. +-- B: NT1 := (DT with D2 => 6); -- OK: DT is unconstrained. +-- C: NT1 := (ST with D2 => 6); -- NO: ST.D1 /= D2. +-- +-- D: NT2 := (T with D2 => 4); -- OK: T is unconstrained. +-- E: NT2 := (DT with D2 => 4); -- OK: DT is unconstrained. +-- F: NT2 := (ST with . . . ); -- NO: ST.D1 /= DT.D1 as specified in NT2. +-- +-- G: NT3 := (T with D1 => 6); -- OK: T is unconstrained. +-- H: NT3 := (DT with D1 => 6); -- OK: DT is unconstrained. +-- I: NT3 := (ST with D1 => 6); -- NO: ST.D1 /= DT.D1 as specified in NT3. +-- +-- In A, B, D, E, G, and H the ancestor part is the name of an +-- unconstrained subtype, so this rule does not apply. In C, F, and I +-- the ancestor part (ST) is the name of a constrained subtype of DT, +-- which is itself a derived type of a discriminated tagged type T. ST +-- constrains the discriminant of DT (D1) to the value 3; thus, the +-- type of any extension aggregate for which ST is the ancestor part +-- must have an ancestor which also constrained D1 to 3. F and I raise +-- Constraint_Error because NT2 and NT3, respectively, constrain D1 to +-- 6. C raises Constraint_Error because NT1 constrains D1 to the value +-- of D2, which is set to 6 in the record component association list of +-- the aggregate. +-- +-- This test verifies each of the three scenarios above: +-- +-- (1) Ancestor of type of aggregate constrains discriminant with +-- new discriminant. +-- (2) Ancestor of type of aggregate constrains discriminant with +-- value, and has a new discriminant part. +-- (3) Ancestor of type of aggregate constrains discriminant with +-- value, and has no discriminant part. +-- +-- Verification is made for cases where the type of the aggregate is +-- once- and twice-removed from the type of the ancestor part. +-- +-- Additionally, a case is included where a new discriminant corresponds +-- to multiple discriminants of the type of the ancestor part. +-- +-- To test the portion of the objective concerning "initialization by +-- default," the test verifies that, after a successful aggregate +-- assignment, components not assigned an explicit value by the aggregate +-- contain the default values for the corresponding components of the +-- ancestor type. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 Dec 94 SAIC Removed discriminant defaults from tagged types. +-- 17 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected subtype constraint +-- for component NT_C3.Str2. Added missing component +-- checks. Removed record component update from +-- Avoid_Optimization. Fixed incorrect component +-- checks. +-- 02 Dec 95 SAIC ACVC 2.0.1 fixes: Corrected Failed comment for +-- Q case. +-- +--! + +package C432003_0 is + + Default_String : constant String := "This is a default string"; -- len = 24 + Another_String : constant String := "Another default string"; -- len = 22 + + subtype Length is Natural range 0..255; + + type ROOT (D1 : Length) is tagged + record + S1 : String (1..D1) := Default_String(1..D1); + Acc : Natural := 356; + end record; + + procedure Avoid_Optimization (Rec : in out ROOT); -- Inherited by all type + -- extensions. + + type Unconstrained_Der is new ROOT with + record + Str1 : String(1..5) := "abcde"; + end record; + + subtype Constrained_Subtype is Unconstrained_Der (D1 => 10); + + type NT_A1 (D2 : Length) is new Unconstrained_Der (D1 => D2) with + record + S2 : String(1..D2); -- Inherited discrim. constrained by + end record; -- new discriminant. + + type NT_A2 (D3 : Length) is new NT_A1 (D2 => D3) with + record + S3 : String(1..D3); -- Inherited discrim. constrained by + end record; -- new discriminant. + + + type NT_B1 (D2 : Length) is new Unconstrained_Der (D1 => 5) with + record + S2 : String(1..D2); -- Inherited discrim. constrained by + end record; -- explicit value. + + type NT_B2 (D3 : Length) is new NT_B1 (D2 => 10) with + record + S3 : String(1..D3); -- Inherited discrim. constrained by + end record; -- explicit value. + + type NT_B3 (D2 : Length) is new Unconstrained_Der (D1 => 10) with + record + S2 : String(1..D2); + end record; + + + type NT_C1 is new Unconstrained_Der (D1 => 5) with + record + Str2 : String(1..5); -- Inherited discrim. constrained + end record; -- No new value. + + type NT_C2 (D2 : Length) is new NT_C1 with + record + S2 : String(1..D2); -- Inherited discrim. not further + end record; -- constrained, new discriminant. + + type NT_C3 is new Unconstrained_Der(D1 => 10) with + record + Str2 : String(1..5); + end record; + + + type MULTI_ROOT (D1 : Length; D2 : Length) is tagged + record + S1 : String (1..D1) := Default_String(1..D1); + S2 : String (1..D2) := Another_String(1..D2); + end record; + + procedure Avoid_Optimization (Rec : in out MULTI_ROOT); -- Inherited by all + -- type extensions. + + type Mult_Unconstr_Der is new MULTI_ROOT with + record + Str1 : String(1..8) := "AbCdEfGh"; -- Derived, no constraints. + end record; + + -- Subtypes with constrained discriminants. + subtype Mult_Constr_Sub1 is Mult_Unconstr_Der(D1 => 15, -- Disc. have + D2 => 20); -- diff values + + subtype Mult_Constr_Sub2 is Mult_Unconstr_Der(D1 => 15, -- Disc. have + D2 => 15); -- same value + + type Mult_NT_A1 (D3 : Length) is + new Mult_Unconstr_Der (D1 => D3, D2 => D3) with + record + S3 : String(1..D3); -- Both inherited discriminants constrained + end record; -- by new discriminant. + +end C432003_0; + + + --=====================================================================-- + + +with Report; +package body C432003_0 is + + procedure Avoid_Optimization (Rec : in out ROOT) is + begin + Rec.S1 := Report.Ident_Str(Rec.S1); + end Avoid_Optimization; + + procedure Avoid_Optimization (Rec : in out MULTI_ROOT) is + begin + Rec.S1 := Report.Ident_Str(Rec.S1); + end Avoid_Optimization; + +end C432003_0; + + + --=====================================================================-- + + +with C432003_0; +with Report; +procedure C432003 is +begin + + Report.Test("C432003", "Extension aggregates where ancestor part " & + "is a subtype mark that denotes a constrained " & + "subtype causing Constraint_Error if any " & + "discriminant of the ancestor has a different " & + "value than that specified for a corresponding " & + "discriminant in the derived type definition " & + "for some ancestor of the type of the aggregate"); + + Test_Block: + declare + + -- Variety of string object declarations. + String2 : String(1..2) := Report.Ident_Str("12"); + String5 : String(1..5) := Report.Ident_Str("12345"); + String8 : String(1..8) := Report.Ident_Str("AbCdEfGh"); + String10 : String(1..10) := Report.Ident_Str("1234567890"); + String15 : String(1..15) := Report.Ident_Str("123456789012345"); + String20 : String(1..20) := Report.Ident_Str("12345678901234567890"); + + begin + + + begin + declare + A : C432003_0.NT_A1 := -- OK + (C432003_0.ROOT with D2 => 5, + Str1 => "cdefg", + S2 => String5); + begin + C432003_0.Avoid_Optimization(A); + if A.Acc /= 356 or + A.Str1 /= "cdefg" or + A.S2 /= String5 or + A.D2 /= 5 or + A.S1 /= C432003_0.Default_String(1..5) + then + Report.Failed("Incorrect object values for Object A"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object A"); + end; + + + begin + declare + C: C432003_0.NT_A1 := -- OK + (C432003_0.Constrained_Subtype with D2 => 10, + S2 => String10); + begin + C432003_0.Avoid_Optimization(C); + if C.D2 /= 10 or C.Acc /= 356 or + C.Str1 /= "abcde" or C.S2 /= String10 or + C.S1 /= C432003_0.Default_String(1..10) + then + Report.Failed("Incorrect object values for Object C"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object C"); + end; + + + begin + declare + D: C432003_0.NT_A1 := -- C_E + (C432003_0.Constrained_Subtype with + D2 => Report.Ident_Int(5), + S2 => String5); + begin + C432003_0.Avoid_Optimization(D); + Report.Failed("Constraint_Error not raised for Object D"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + E: C432003_0.NT_A2 := -- OK + (C432003_0.Constrained_Subtype with D3 => 10, + S2 => String10, + S3 => String10); + begin + C432003_0.Avoid_Optimization(E); + if E.D3 /= 10 or E.Acc /= 356 or + E.Str1 /= "abcde" or E.S2 /= String10 or + E.S3 /= String10 or + E.S1 /= C432003_0.Default_String(1..10) + then + Report.Failed("Incorrect object values for Object E"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object E"); + end; + + + begin + declare + F: C432003_0.NT_A2 := -- C_E + (C432003_0.Constrained_Subtype with + D3 => Report.Ident_Int(5), + S2 => String5, + S3 => String5); + begin + C432003_0.Avoid_Optimization(F); + Report.Failed("Constraint_Error not raised for Object F"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + G: C432003_0.NT_B2 := -- OK + (C432003_0.ROOT with D3 => 5, + Str1 => "cdefg", + S2 => String10, + S3 => String5); + begin + C432003_0.Avoid_Optimization(G); + if G.D3 /= 5 or G.Acc /= 356 or + G.Str1 /= "cdefg" or G.S2 /= String10 or + G.S3 /= String5 or + G.S1 /= C432003_0.Default_String(1..5) + then + Report.Failed("Incorrect object values for Object G"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object G"); + end; + + + begin + declare + H: C432003_0.NT_B3 := -- OK + (C432003_0.Unconstrained_Der with D2 => 5, + S2 => String5); + begin + C432003_0.Avoid_Optimization(H); + if H.D2 /= 5 or H.Acc /= 356 or + H.Str1 /= "abcde" or H.S2 /= String5 or + H.S1 /= C432003_0.Default_String(1..10) + then + Report.Failed("Incorrect object values for Object H"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object H"); + end; + + + begin + declare + I: C432003_0.NT_B1 := -- C_E + (C432003_0.Constrained_Subtype with + D2 => Report.Ident_Int(10), + S2 => String10); + begin + C432003_0.Avoid_Optimization(I); + Report.Failed("Constraint_Error not raised for Object I"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + J: C432003_0.NT_B2 := -- C_E + (C432003_0.Constrained_Subtype with + D3 => Report.Ident_Int(10), + S2 => String10, + S3 => String10); + begin + C432003_0.Avoid_Optimization(J); + Report.Failed("Constraint_Error not raised by Object J"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + K: C432003_0.NT_B3 := -- OK + (C432003_0.Constrained_Subtype with D2 => 5, + S2 => String5); + begin + C432003_0.Avoid_Optimization(K); + if K.D2 /= 5 or K.Acc /= 356 or + K.Str1 /= "abcde" or K.S2 /= String5 or + K.S1 /= C432003_0.Default_String(1..10) + then + Report.Failed("Incorrect object values for Object K"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object K"); + end; + + + begin + declare + M: C432003_0.NT_C2 := -- OK + (C432003_0.ROOT with D2 => 10, + Str1 => "cdefg", + Str2 => String5, + S2 => String10); + begin + C432003_0.Avoid_Optimization(M); + if M.D2 /= 10 or M.Acc /= 356 or + M.Str1 /= "cdefg" or M.S2 /= String10 or + M.Str2 /= String5 or + M.S1 /= C432003_0.Default_String(1..5) + then + Report.Failed("Incorrect object values for Object M"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object M"); + end; + + + begin + declare + O: C432003_0.NT_C1 := -- C_E + (C432003_0.Constrained_Subtype with + Str2 => Report.Ident_Str(String5)); + begin + C432003_0.Avoid_Optimization(O); + Report.Failed("Constraint_Error not raised for Object O"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + P: C432003_0.NT_C2 := -- C_E + (C432003_0.Constrained_Subtype with + D2 => Report.Ident_Int(10), + Str2 => String5, + S2 => String10); + begin + C432003_0.Avoid_Optimization(P); + Report.Failed("Constraint_Error not raised by Object P"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + Q: C432003_0.NT_C3 := + (C432003_0.Constrained_Subtype with Str2 => String5); -- OK + begin + C432003_0.Avoid_Optimization(Q); + if Q.Str2 /= String5 or + Q.Acc /= 356 or + Q.Str1 /= "abcde" or + Q.D1 /= 10 or + Q.S1 /= C432003_0.Default_String(1..10) + then + Report.Failed("Incorrect object values for Object Q"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object Q"); + end; + + + -- The following cases test where a new discriminant corresponds + -- to multiple discriminants of the type of the ancestor part. + + begin + declare + S: C432003_0.Mult_NT_A1 := -- OK + (C432003_0.Mult_Unconstr_Der with D3 => 15, + S3 => String15); + begin + C432003_0.Avoid_Optimization(S); + if S.S1 /= C432003_0.Default_String(1..15) or + S.Str1 /= String8 or + S.S2 /= C432003_0.Another_String(1..15) or + S.S3 /= String15 or + S.D3 /= 15 + then + Report.Failed("Incorrect object values for Object S"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object S"); + end; + + + begin + declare + U: C432003_0.Mult_NT_A1 := -- C_E + (C432003_0.Mult_Constr_Sub1 with + D3 => Report.Ident_Int(15), + S3 => String15); + begin + C432003_0.Avoid_Optimization(U); + Report.Failed("Constraint_Error not raised for Object U"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + V: C432003_0.Mult_NT_A1 := -- OK + (C432003_0.Mult_Constr_Sub2 with D3 => 15, + S3 => String15); + begin + C432003_0.Avoid_Optimization(V); + if V.D3 /= 15 or + V.Str1 /= String8 or + V.S3 /= String15 or + V.S1 /= C432003_0.Default_String(1..15) or + V.S2 /= C432003_0.Another_String(1..15) + then + Report.Failed("Incorrect object values for Object V"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object V"); + end; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + +end C432003; diff --git a/gcc/testsuite/ada/acats/tests/c4/c432004.a b/gcc/testsuite/ada/acats/tests/c4/c432004.a new file mode 100644 index 000000000..3a1486211 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c432004.a @@ -0,0 +1,319 @@ +-- C432004.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 of an extension aggregate may be derived from the +-- type of the ancestor part through multiple record extensions. Check +-- for ancestor parts that are subtype marks. Check that the type of the +-- ancestor part may be abstract. +-- +-- TEST DESCRIPTION: +-- This test defines the following type hierarchies: +-- +-- (A) (F) +-- Abstract Abstract +-- Tagged record Tagged private +-- / \ / \ +-- / (C) (G) \ +-- (B) Abstract Abstract (H) +-- Record private record Private +-- extension extension extension extension +-- | | | | +-- (D) (E) (I) (J) +-- Record Record Record Record +-- extension extension extension extension +-- +-- Extension aggregates for B, D, E, I, and J are constructed using each +-- of its ancestor types as the ancestor part (except for E and J, for +-- which only the immediate ancestor is used, since using A and F, +-- respectively, as the ancestor part would be illegal). +-- +-- X1 : B := (A with ...); +-- X2 : D := (A with ...); X5 : I := (F with ...); +-- X3 : D := (B with ...); X6 : I := (G with ...); +-- X4 : E := (C with ...); X7 : J := (H with ...); +-- +-- For each assignment of an aggregate, the value of the target object is +-- checked to ensure that the proper values for each component were +-- assigned. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C432004_0 is + + type Drawers is record + Building : natural; + end record; + + type Location is access Drawers; + + type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic); + + type SampleType_A is abstract tagged record + Era : Eras := Cenozoic; + Loc : Location; + end record; + + type SampleType_F is abstract tagged private; + + -- The following function is needed to verify the values of the + -- private components. + function TC_Correct_Result (Rec : SampleType_F'Class; + E : Eras) return Boolean; + +private + type SampleType_F is abstract tagged record + Era : Eras := Mesozoic; + end record; + +end C432004_0; + + --==================================================================-- + +package body C432004_0 is + + function TC_Correct_Result (Rec : SampleType_F'Class; + E : Eras) return Boolean is + begin + return (Rec.Era = E); + end TC_Correct_Result; + +end C432004_0; + + --==================================================================-- + +with C432004_0; +package C432004_1 is + + type Periods is + (Aphebian, Helikian, Hadrynian, + Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian, + Triassic, Jurassic, Cretaceous, + Tertiary, Quaternary); + + type SampleType_B is new C432004_0.SampleType_A with record + Period : Periods := Quaternary; + end record; + + type SampleType_C is abstract new C432004_0.SampleType_A with private; + + -- The following function is needed to verify the values of the + -- extension's private components. + function TC_Correct_Result (Rec : SampleType_C'Class; + P : Periods) return Boolean; + + type SampleType_G is abstract new C432004_0.SampleType_F with record + Period : Periods := Jurassic; + Loc : C432004_0.Location; + end record; + + type SampleType_H is new C432004_0.SampleType_F with private; + + -- The following function is needed to verify the values of the + -- extension's private components. + function TC_Correct_Result (Rec : SampleType_H'Class; + P : Periods; + E : C432004_0.Eras) return Boolean; + +private + type SampleType_C is abstract new C432004_0.SampleType_A with record + Period : Periods := Quaternary; + end record; + + type SampleType_H is new C432004_0.SampleType_F with record + Period : Periods := Jurassic; + end record; + +end C432004_1; + + --==================================================================-- + +package body C432004_1 is + + function TC_Correct_Result (Rec : SampleType_C'Class; + P : Periods) return Boolean is + begin + return (Rec.Period = P); + end TC_Correct_Result; + + ------------------------------------------------------------- + function TC_Correct_Result (Rec : SampleType_H'Class; + P : Periods; + E : C432004_0.Eras) return Boolean is + begin + return (Rec.Period = P) and C432004_0.TC_Correct_Result (Rec, E); + end TC_Correct_Result; + +end C432004_1; + + --==================================================================-- + +with C432004_0; +with C432004_1; +package C432004_2 is + + -- All types herein are record extensions, since aggregates + -- cannot be given for private extensions + + type SampleType_D is new C432004_1.SampleType_B with record + Sample_On_Loan : Boolean := False; + end record; + + type SampleType_E is new C432004_1.SampleType_C + with null record; + + type SampleType_I is new C432004_1.SampleType_G with record + Sample_On_Loan : Boolean := True; + end record; + + type SampleType_J is new C432004_1.SampleType_H with record + Sample_On_Loan : Boolean := True; + end record; + +end C432004_2; + + + --==================================================================-- + +with Report; +with C432004_0; +with C432004_1; +with C432004_2; +use C432004_1; +use C432004_2; + +procedure C432004 is + + -- Variety of extension aggregates. + + -- Default values for the components of SampleType_A + -- (Era => Cenozoic, Loc => null). + Sample_B : SampleType_B + := (C432004_0.SampleType_A with Period => Devonian); + + -- Default values from SampleType_A (Era => Cenozoic, Loc => null). + Sample_D1 : SampleType_D + := (C432004_0.SampleType_A with Period => Cambrian, + Sample_On_Loan => True); + + -- Default values from SampleType_A and SampleType_B + -- (Era => Cenozoic, Loc => null, Period => Quaternary). + Sample_D2 : SampleType_D + := (SampleType_B with Sample_On_Loan => True); + + -- Default values from SampleType_A and SampleType_C + -- (Era => Cenozoic, Loc => null, Period => Quaternary). + Sample_E : SampleType_E + := (SampleType_C with null record); + + -- Default value from SampleType_F (Era => Mesozoic). + Sample_I1 : SampleType_I + := (C432004_0.SampleType_F with Period => Tertiary, + Loc => new C432004_0.Drawers'(Building => 9), + Sample_On_Loan => False); + + -- Default values from SampleType_F and SampleType_G + -- (Era => Mesozoic, Period => Jurassic, Loc => null). + Sample_I2 : SampleType_I + := (SampleType_G with Sample_On_Loan => False); + + -- Default values from SampleType_H (Era => Mesozoic, Period => Jurassic). + Sample_J : SampleType_J + := (SampleType_H with Sample_On_Loan => False); + + use type C432004_0.Eras; + use type C432004_0.Location; + +begin + + Report.Test ("C432004", "Check that the type of an extension aggregate " & + "may be derived from the type of the ancestor part through " & + "multiple record extensions"); + + if Sample_B /= (C432004_0.Cenozoic, null, Devonian) then + Report.Failed ("Object of record extension of abstract ancestor, " & + "SampleType_B, failed content check"); + end if; + + ------------------- + if Sample_D1 /= (Era => C432004_0.Cenozoic, Loc => null, + Period => Cambrian, Sample_On_Loan => True) then + Report.Failed ("Object 1 of record extension of record extension, " & + "of abstract ancestor, SampleType_D, failed content " & + "check"); + end if; + + ------------------- + if Sample_D2 /= (C432004_0.Cenozoic, null, Quaternary, True) then + Report.Failed ("Object 2 of record extension of record extension, " & + "of abstract ancestor, SampleType_D, failed content " & + "check"); + end if; + ------------------- + if Sample_E.Era /= C432004_0.Cenozoic or + Sample_E.Loc /= null or + not TC_Correct_Result (Sample_E, Quaternary) then + Report.Failed ("Object of record extension of abstract private " & + "extension of abstract ancestor, SampleType_E, " & + "failed content check"); + end if; + + ------------------- + if not C432004_0.TC_Correct_Result (Sample_I1, C432004_0.Mesozoic) or + Sample_I1.Period /= Tertiary or + Sample_I1.Loc.Building /= 9 or + Sample_I1.Sample_On_Loan /= False then + Report.Failed ("Object 1 of record extension of abstract record " & + "extension of abstract private ancestor, " & + "SampleType_I, failed content check"); + end if; + + ------------------- + if not C432004_0.TC_Correct_Result (Sample_I2, C432004_0.Mesozoic) or + Sample_I2.Period /= Jurassic or + Sample_I2.Loc /= null or + Sample_I2.Sample_On_Loan /= False then + Report.Failed ("Object 2 of record extension of abstract record " & + "extension of abstract private ancestor, " & + "SampleType_I, failed content check"); + end if; + + ------------------- + if not TC_Correct_Result (Sample_J, + Jurassic, + C432004_0.Mesozoic) or + Sample_J.Sample_On_Loan /= False then + Report.Failed ("Object of record extension of private extension " & + "of abstract private ancestor, SampleType_J, " & + "failed content check"); + end if; + + Report.Result; + +end C432004; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204a.ada b/gcc/testsuite/ada/acats/tests/c4/c43204a.ada new file mode 100644 index 000000000..33450dba0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204a.ada @@ -0,0 +1,158 @@ +-- C43204A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS CHOICE CAN APPEAR +-- (AND BOUNDS ARE DETERMINED CORRECTLY) AS AN ACTUAL PARAMETER OF +-- A SUBPROGRAM CALL WHEN THE FORMAL PARAMETER IS CONSTRAINED. + +-- HISTORY: +-- JET 08/04/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43204A IS + + TYPE ARR10 IS ARRAY(IDENT_INT(1)..IDENT_INT(0)) OF INTEGER; + TYPE ARR11 IS ARRAY(INTEGER RANGE -3..3) OF INTEGER; + TYPE ARR12 IS ARRAY(IDENT_INT(-3)..IDENT_INT(3)) OF INTEGER; + + TYPE ARR20 IS ARRAY(IDENT_INT(1)..IDENT_INT(0), + IDENT_INT(0)..IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY(INTEGER RANGE -1..1, + INTEGER RANGE -1..1) OF INTEGER; + TYPE ARR22 IS ARRAY(IDENT_INT(-1)..IDENT_INT(1), + IDENT_INT(-1)..IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY(INTEGER'(-1)..1, + IDENT_INT(-1)..IDENT_INT(1)) OF INTEGER; + + PROCEDURE PROC10 (A : ARR10) IS + BEGIN + IF A'LENGTH /= IDENT_INT(0) THEN + FAILED ("PROC10 ARRAY IS NOT NULL"); + END IF; + END PROC10; + + PROCEDURE PROC11 (A : ARR11; C : INTEGER) IS + BEGIN + IF A'LENGTH /= IDENT_INT(7) OR + A'FIRST /= IDENT_INT(-3) OR + A'LAST /= IDENT_INT(3) THEN + FAILED ("INCORRECT LENGTH IN PROC11 CALL NUMBER" & + INTEGER'IMAGE(C)); + END IF; + + FOR I IN IDENT_INT(-3)..IDENT_INT(3) LOOP + IF IDENT_INT(A(I)) /= C THEN + FAILED ("INCORRECT VALUE OF COMPONENT " & + INTEGER'IMAGE(I) & ", PROC11 CALL NUMBER" & + INTEGER'IMAGE(C)); + END IF; + END LOOP; + END PROC11; + + PROCEDURE PROC12 (A : ARR12) IS + BEGIN + IF A'LENGTH /= IDENT_INT(7) THEN + FAILED ("INCORRECT LENGTH IN PROC12"); + END IF; + + FOR I IN IDENT_INT(-3)..IDENT_INT(3) LOOP + IF IDENT_INT(A(I)) /= 3 THEN + FAILED ("INCORRECT VALUE OF COMPONENT " & + INTEGER'IMAGE(I) & ", PROC12"); + END IF; + END LOOP; + END PROC12; + + PROCEDURE PROC20 (A : ARR20) IS + BEGIN + IF A'LENGTH(1) /= IDENT_INT(0) OR + A'LENGTH(2) /= IDENT_INT(0) THEN + FAILED ("PROC20 ARRAY IS NOT NULL"); + END IF; + END PROC20; + + PROCEDURE PROC21 (A : ARR21; C : INTEGER) IS + BEGIN + FOR I IN INTEGER'(-1)..1 LOOP + FOR J IN INTEGER'(-1)..1 LOOP + IF IDENT_INT(A(I,J)) /= C THEN + FAILED ("INCORRECT VALUE OF COMPONENT (" & + INTEGER'IMAGE(I) & "," & + INTEGER'IMAGE(J) & "), PROC21 CALL " & + "NUMBER" & INTEGER'IMAGE(C)); + END IF; + END LOOP; + END LOOP; + END PROC21; + + PROCEDURE PROC22 (A : ARR22) IS + BEGIN + FOR I IN INTEGER'(-1)..1 LOOP + FOR J IN INTEGER'(-1)..1 LOOP + IF IDENT_INT(A(I,J)) /= 5 THEN + FAILED ("INCORRECT VALUE OF COMPONENT (" & + INTEGER'IMAGE(I) & "," & + INTEGER'IMAGE(J) & "), PROC22"); + END IF; + END LOOP; + END LOOP; + END PROC22; + + PROCEDURE PROC23 (A : ARR23) IS + BEGIN + FOR I IN INTEGER'(-1)..1 LOOP + FOR J IN INTEGER'(-1)..1 LOOP + IF IDENT_INT(A(I,J)) /= 7 THEN + FAILED ("INCORRECT VALUE OF COMPONENT (" & + INTEGER'IMAGE(I) & "," & + INTEGER'IMAGE(J) & "), PROC23"); + END IF; + END LOOP; + END LOOP; + END PROC23; + +BEGIN + TEST ("C43204A", "CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS " & + "CHOICE CAN APPEAR (AND BOUNDS ARE DETERMINED " & + "CORRECTLY) AS AN ACTUAL PARAMETER OF A " & + "SUBPROGRAM CALL WHEN THE FORMAL PARAMETER IS " & + "CONSTRAINED"); + + PROC11 ((1,1,1, OTHERS => 1), 1); + PROC11 ((2 => 2, 3 => 2, OTHERS => 2), 2); + PROC12 ((OTHERS => 3)); + PROC10 ((OTHERS => 4)); + + PROC21 (((1,1,1), OTHERS => (1,1,1)), 1); + PROC21 ((1 => (2,2,2), OTHERS => (2,2,2)), 2); + PROC21 (((3,OTHERS => 3), (3,OTHERS => 3), (3,3,OTHERS => 3)), 3); + PROC21 (((-1 => 4, OTHERS => 4), (0 => 4, OTHERS => 4), + (1 => 4, OTHERS => 4)), 4); + PROC22 ((OTHERS => (OTHERS => 5))); + PROC20 ((OTHERS => (OTHERS => 6))); + PROC23 ((OTHERS => (7,7,7))); + + RESULT; +END C43204A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204c.ada b/gcc/testsuite/ada/acats/tests/c4/c43204c.ada new file mode 100644 index 000000000..1db9f7f17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204c.ada @@ -0,0 +1,192 @@ +-- C43204C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS CHOICE CAN APPEAR +-- (AND BOUNDS ARE DETERMINED CORRECTLY) AS AN ACTUAL PARAMETER OF +-- A GENERIC INSTANTIATION WHEN THE GENERIC FORMAL PARAMETER IS +-- CONSTRAINED. + +-- HISTORY: +-- JET 08/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43204C IS + + TYPE ARR10 IS ARRAY(IDENT_INT(1)..IDENT_INT(0)) OF INTEGER; + TYPE ARR11 IS ARRAY(INTEGER RANGE -3..3) OF INTEGER; + TYPE ARR12 IS ARRAY(IDENT_INT(-3)..IDENT_INT(3)) OF INTEGER; + + TYPE ARR20 IS ARRAY(IDENT_INT(1)..IDENT_INT(0), + IDENT_INT(0)..IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY(INTEGER RANGE -1..1, + INTEGER RANGE -1..1) OF INTEGER; + TYPE ARR22 IS ARRAY(IDENT_INT(-1)..IDENT_INT(1), + IDENT_INT(-1)..IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY(INTEGER'(-1)..1, + IDENT_INT(-1)..IDENT_INT(1)) OF INTEGER; + + GENERIC + A : ARR10; + PROCEDURE GPROC10; + + GENERIC + A : ARR11; + PROCEDURE GPROC11; + + GENERIC + A : ARR12; + PROCEDURE GPROC12; + + GENERIC + A : ARR20; + PROCEDURE GPROC20; + + GENERIC + A : ARR21; + PROCEDURE GPROC21 (C : INTEGER); + + GENERIC + A : ARR22; + PROCEDURE GPROC22; + + GENERIC + A : ARR23; + PROCEDURE GPROC23; + + PROCEDURE GPROC10 IS + BEGIN + IF A'LENGTH /= IDENT_INT(0) THEN + FAILED ("PROC10 ARRAY IS NOT NULL"); + END IF; + END GPROC10; + + PROCEDURE GPROC11 IS + BEGIN + IF A'LENGTH /= IDENT_INT(7) OR + A'FIRST /= IDENT_INT(-3) OR + A'LAST /= IDENT_INT(3) THEN + FAILED ("INCORRECT LENGTH IN PROC11"); + END IF; + + FOR I IN IDENT_INT(-3)..IDENT_INT(3) LOOP + IF IDENT_INT(A(I)) /= 1 THEN + FAILED ("INCORRECT VALUE OF COMPONENT " & + INTEGER'IMAGE(I) & ", PROC11"); + END IF; + END LOOP; + END GPROC11; + + PROCEDURE GPROC12 IS + BEGIN + IF A'LENGTH /= IDENT_INT(7) THEN + FAILED ("INCORRECT LENGTH IN PROC12"); + END IF; + + FOR I IN IDENT_INT(-3)..IDENT_INT(3) LOOP + IF IDENT_INT(A(I)) /= 2 THEN + FAILED ("INCORRECT VALUE OF COMPONENT " & + INTEGER'IMAGE(I) & ", PROC12"); + END IF; + END LOOP; + END GPROC12; + + PROCEDURE GPROC20 IS + BEGIN + IF A'LENGTH(1) /= IDENT_INT(0) OR + A'LENGTH(2) /= IDENT_INT(0) THEN + FAILED ("GPROC20 ARRAY IS NOT NULL"); + END IF; + END GPROC20; + + PROCEDURE GPROC21 (C : INTEGER) IS + BEGIN + FOR I IN INTEGER'(-1)..1 LOOP + FOR J IN INTEGER'(-1)..1 LOOP + IF IDENT_INT(A(I,J)) /= C THEN + FAILED ("INCORRECT VALUE OF COMPONENT (" & + INTEGER'IMAGE(I) & "," & + INTEGER'IMAGE(J) & "), GPROC21 CALL " & + "NUMBER" & INTEGER'IMAGE(C)); + END IF; + END LOOP; + END LOOP; + END GPROC21; + + PROCEDURE GPROC22 IS + BEGIN + FOR I IN INTEGER'(-1)..1 LOOP + FOR J IN INTEGER'(-1)..1 LOOP + IF IDENT_INT(A(I,J)) /= 3 THEN + FAILED ("INCORRECT VALUE OF COMPONENT (" & + INTEGER'IMAGE(I) & "," & + INTEGER'IMAGE(J) & "), GPROC22"); + END IF; + END LOOP; + END LOOP; + END GPROC22; + + PROCEDURE GPROC23 IS + BEGIN + FOR I IN INTEGER'(-1)..1 LOOP + FOR J IN INTEGER'(-1)..1 LOOP + IF IDENT_INT(A(I,J)) /= 4 THEN + FAILED ("INCORRECT VALUE OF COMPONENT (" & + INTEGER'IMAGE(I) & "," & + INTEGER'IMAGE(J) & "), GPROC23"); + END IF; + END LOOP; + END LOOP; + END GPROC23; + + PROCEDURE PROC11 IS NEW GPROC11((1,1,1, OTHERS => 1)); + PROCEDURE PROC12 IS NEW GPROC12((OTHERS => 2)); + PROCEDURE PROC10 IS NEW GPROC10((OTHERS => 3)); + + PROCEDURE PROC21 IS NEW GPROC21(((1,1,1), OTHERS => (1,1,1))); + PROCEDURE PROC22 IS NEW GPROC21(((2,OTHERS => 2), (2,OTHERS => 2), + (2,2,OTHERS => 2))); + PROCEDURE PROC23 IS NEW GPROC22((OTHERS => (OTHERS => 3))); + PROCEDURE PROC24 IS NEW GPROC23((OTHERS => (4,4,4))); + PROCEDURE PROC20 IS NEW GPROC20((OTHERS => (OTHERS => 5))); + +BEGIN + TEST ("C43204C", "CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS " & + "CHOICE CAN APPEAR (AND BOUNDS ARE DETERMINED " & + "CORRECTLY) AS AN ACTUAL PARAMETER OF A " & + "SUBPROGRAM CALL WHEN THE FORMAL PARAMETER IS " & + "CONSTRAINED"); + + PROC11; + PROC12; + PROC10; + + PROC21(1); + PROC22(2); + PROC23; + PROC24; + PROC20; + + RESULT; +END C43204C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204e.ada b/gcc/testsuite/ada/acats/tests/c4/c43204e.ada new file mode 100644 index 000000000..8b6566660 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204e.ada @@ -0,0 +1,179 @@ +-- C43204E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS CHOICE CAN APPEAR +-- AS THE INITIALIZATION EXPRESSION OF A CONSTRAINED CONSTANT, +-- VARIABLE OBJECT DECLARATION, OR RECORD COMPONENT DECLARATION, +-- AND THAT THE BOUNDS OF THE AGGREGATE ARE DETERMINED CORRECTLY. + +-- HISTORY: +-- JET 08/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43204E IS + + TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER; + TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER; + TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1, + INTEGER RANGE -1 .. 1) OF INTEGER; + TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1, + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + + CA11 : CONSTANT ARR11 := (1, OTHERS => IDENT_INT(2)); + CA12 : CONSTANT ARR12 := (OTHERS => IDENT_INT(2)); + CA13 : CONSTANT ARR13 := (OTHERS => IDENT_INT(2)); + CA21 : CONSTANT ARR21 := (OTHERS => (-1..1 => IDENT_INT(2))); + CA22 : CONSTANT ARR22 := (OTHERS => (-1..1 => IDENT_INT(2))); + CA23 : CONSTANT ARR23 := (-1..1 => (OTHERS => IDENT_INT(2))); + CA24 : CONSTANT ARR24 := (OTHERS => (OTHERS => IDENT_INT(2))); + + VA11 : ARR11 := (1,1, OTHERS => IDENT_INT(2)); + VA12 : ARR12 := (OTHERS => IDENT_INT(2)); + VA13 : ARR13 := (OTHERS => IDENT_INT(2)); + VA21 : ARR21 := ((1,1,1), OTHERS => (-1..1 => IDENT_INT(2))); + VA22 : ARR22 := (-1 => (1,1,1), 0..1 => (OTHERS => IDENT_INT(2))); + VA23 : ARR23 := (OTHERS => (OTHERS => IDENT_INT(2))); + VA24 : ARR24 := (OTHERS => (OTHERS => IDENT_INT(2))); + + TYPE REC IS RECORD + RA11 : ARR11 := (1,1,1, OTHERS => IDENT_INT(2)); + RA12 : ARR12 := (OTHERS => IDENT_INT(2)); + RA13 : ARR13 := (OTHERS => IDENT_INT(2)); + RA21 : ARR21 := ((1,1,1), (1,1,1), OTHERS => (IDENT_INT(2), + IDENT_INT(2), IDENT_INT(2))); + RA22 : ARR22 := (OTHERS => (OTHERS => IDENT_INT(2))); + RA23 : ARR23 := (-1 => (OTHERS => 1), + 0..1 => (OTHERS => IDENT_INT(2))); + RA24 : ARR24 := (OTHERS => (OTHERS => IDENT_INT(2))); + END RECORD; + + R : REC; + +BEGIN + TEST ("C43204E", "CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS " & + "CHOICE CAN APPEAR AS THE INITIALIZATION " & + "EXPRESSION OF A CONSTRAINED CONSTANT, " & + "VARIABLE OBJECT DECLARATION, OR RECORD " & + "COMPONENT DECLARATION, AND THAT THE BOUNDS OF " & + "THE AGGREGATE ARE DETERMINED CORRECTLY"); + + IF CA11 /= (1, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF CA11"); + END IF; + + IF CA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF CA12"); + END IF; + + IF CA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF CA13"); + END IF; + + IF CA21 /= ((2,2,2), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF CA21"); + END IF; + + IF CA22 /= ((2,2,2), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF CA22"); + END IF; + + IF CA23 /= ((2,2,2), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF CA23"); + END IF; + + IF CA24'LENGTH /= 0 OR CA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF CA24"); + END IF; + + IF VA11 /= (1, 1, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF VA11"); + END IF; + + IF VA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF VA12"); + END IF; + + IF VA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF VA13"); + END IF; + + IF VA21 /= ((1,1,1), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF VA21"); + END IF; + + IF VA22 /= ((1,1,1), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF VA22"); + END IF; + + IF VA23 /= ((2,2,2), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF VA23"); + END IF; + + IF VA24'LENGTH /= 0 OR VA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF VA24"); + END IF; + + IF R.RA11 /= (1, 1, 1, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF RA11"); + END IF; + + IF R.RA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF RA12"); + END IF; + + IF R.RA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF RA13"); + END IF; + + IF R.RA21 /= ((1,1,1), (1,1,1), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF RA21"); + END IF; + + IF R.RA22 /= ((2,2,2), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF RA22"); + END IF; + + IF R.RA23 /= ((1,1,1), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF RA23"); + END IF; + + IF R.RA24'LENGTH /= 0 OR R.RA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF RA24"); + END IF; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " & + "RAISED"); + + RESULT; +END C43204E; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204f.ada b/gcc/testsuite/ada/acats/tests/c4/c43204f.ada new file mode 100644 index 000000000..bd6cc6170 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204f.ada @@ -0,0 +1,107 @@ +-- C43204F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE CAN APPEAR AS A +-- CONSTRAINED FORMAL PARAMETER OF A SUBPROGRAM AND THAT THE BOUNDS +-- OF THE AGGREGATE ARE DETERMINED CORRECTLY. + +-- HISTORY: +-- JET 08/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43204F IS + + TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER; + TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER; + TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1, + INTEGER RANGE -1 .. 1) OF INTEGER; + TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1, + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + + PROCEDURE PROC (PA11 : ARR11 := (1,1,1,1,1,1, + OTHERS => IDENT_INT(2)); + PA12 : ARR12 := (OTHERS => IDENT_INT(2)); + PA13 : ARR13 := (OTHERS => IDENT_INT(2)); + PA21 : ARR21 := ((1,1,1), (1,1,1), + (1, OTHERS => IDENT_INT(2))); + PA22 : ARR22 := ((1,1,1), (1,1,1), + (OTHERS => IDENT_INT(2))); + PA23 : ARR23 := ((1,1,1), (1,1,1), (1,1,1), + OTHERS => (OTHERS => + IDENT_INT(2))); + PA24 : ARR24 := (OTHERS => (OTHERS => + IDENT_INT(2)))) IS + BEGIN + IF PA11 /= (1, 1, 1, 1, 1, 1, 2) THEN + FAILED("INCORRECT VALUE OF PA11"); + END IF; + + IF PA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF PA12"); + END IF; + + IF PA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF PA13"); + END IF; + + IF PA21 /= ((1,1,1), (1,1,1), (1,2,2)) THEN + FAILED("INCORRECT VALUE OF PA21"); + END IF; + + IF PA22 /= ((1,1,1), (1,1,1), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF PA22"); + END IF; + + IF PA23 /= ((1,1,1), (1,1,1), (1,1,1)) THEN + FAILED("INCORRECT VALUE OF PA23"); + END IF; + + IF PA24'LENGTH /= 0 OR PA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF PA24"); + END IF; + END PROC; + +BEGIN + TEST ("C43204F", "CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE " & + "CAN APPEAR AS A CONSTRAINED FORMAL PARAMETER " & + "OF A SUBPROGRAM AND THAT THE BOUNDS OF THE " & + "AGGREGATE ARE DETERMINED CORRECTLY"); + + PROC; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " & + "RAISED"); + + RESULT; +END C43204F; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204g.ada b/gcc/testsuite/ada/acats/tests/c4/c43204g.ada new file mode 100644 index 000000000..3474e5728 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204g.ada @@ -0,0 +1,125 @@ +-- C43204G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE CAN APPEAR AS A +-- CONSTRAINED FORMAL PARAMETER OF AN ENTRY, AND THAT THE BOUNDS +-- OF THE AGGREGATE ARE DETERMINED CORRECTLY. + +-- HISTORY: +-- JET 08/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43204G IS + + TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER; + TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER; + TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1, + INTEGER RANGE -1 .. 1) OF INTEGER; + TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1, + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + + TASK T IS + ENTRY E (EA11 : ARR11 := (1,1,1,1, OTHERS => IDENT_INT(2)); + EA12 : ARR12 := (OTHERS => IDENT_INT(2)); + EA13 : ARR13 := (OTHERS => IDENT_INT(2)); + EA21 : ARR21 := ((1,1,1), (1,1,1), (1,1,1), + OTHERS => (-1..1 => IDENT_INT(2))); + EA22 : ARR22 := ((OTHERS => IDENT_INT(2)), (1,1,1), + (1,1,1)); + EA23 : ARR23 := (-1..0 => (OTHERS => 1), + 1 => (OTHERS => IDENT_INT(2))); + EA24: ARR24 := (OTHERS => (OTHERS => IDENT_INT(2)))); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (EA11 : ARR11 := (1,1,1,1, OTHERS => IDENT_INT(2)); + EA12 : ARR12 := (OTHERS => IDENT_INT(2)); + EA13 : ARR13 := (OTHERS => IDENT_INT(2)); + EA21 : ARR21 := ((1,1,1), (1,1,1), (1,1,1), + OTHERS => (-1..1 => IDENT_INT(2))); + EA22 : ARR22 := ((OTHERS => IDENT_INT(2)), (1,1,1), + (1,1,1)); + EA23 : ARR23 := (-1..0 => (OTHERS => 1), + 1 => (OTHERS => IDENT_INT(2))); + EA24 : ARR24 := (OTHERS => (OTHERS => + IDENT_INT(2)))) + DO + IF EA11 /= (1, 1, 1, 1, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF EA11"); + END IF; + + IF EA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF EA12"); + END IF; + + IF EA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF EA13"); + END IF; + + IF EA21 /= ((1,1,1), (1,1,1), (1,1,1)) THEN + FAILED("INCORRECT VALUE OF EA21"); + END IF; + + IF EA22 /= ((2,2,2), (1,1,1), (1,1,1)) THEN + FAILED("INCORRECT VALUE OF EA22"); + END IF; + + IF EA23 /= ((1,1,1), (1,1,1), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF EA23"); + END IF; + + IF EA24'LENGTH /= 0 OR EA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF EA24"); + END IF; + END E; + END T; + +BEGIN + TEST ("C43204G", "CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE " & + "CAN APPEAR AS A CONSTRAINED FORMAL PARAMETER " & + "OF AN ENTRY, AND THAT THE BOUNDS OF THE " & + "AGGREGATE ARE DETERMINED CORRECTLY"); + + T.E; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " & + "RAISED"); + + IF T'CALLABLE THEN + T.E; + END IF; + + RESULT; +END C43204G; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204h.ada b/gcc/testsuite/ada/acats/tests/c4/c43204h.ada new file mode 100644 index 000000000..54b19587b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204h.ada @@ -0,0 +1,107 @@ +-- C43204H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE CAN APPEAR AS A +-- CONSTRAINED FORMAL PARAMETER OF A GENERIC UNIT, AND THAT THE +-- BOUNDS OF THE AGGREGATE ARE DETERMINED CORRECTLY. + +-- HISTORY: +-- JET 08/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43204H IS + + TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER; + TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER; + TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1, + INTEGER RANGE -1 .. 1) OF INTEGER; + TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1, + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + + GENERIC + GA11 : ARR11 := (1,1,1,1,1, OTHERS => IDENT_INT(2)); + GA12 : ARR12 := (OTHERS => IDENT_INT(2)); + GA13 : ARR13 := (OTHERS => IDENT_INT(2)); + GA21 : ARR21 := ((1,1,1), (1,1,1), (OTHERS => IDENT_INT(2))); + GA22 : ARR22 := ((1,1,1), (OTHERS => IDENT_INT(2)), (1,1,1)); + GA23 : ARR23 := ((1,1,1), (OTHERS => IDENT_INT(2)), (1,1,1)); + GA24 : ARR24 := (OTHERS => (OTHERS => IDENT_INT(2))); + PROCEDURE GEN; + + PROCEDURE GEN IS + BEGIN + IF GA11 /= (1, 1, 1, 1, 1, 2, 2) THEN + FAILED("INCORRECT VALUE OF GA11"); + END IF; + + IF GA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF GA12"); + END IF; + + IF GA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF GA13"); + END IF; + + IF GA21 /= ((1,1,1), (1,1,1), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF GA21"); + END IF; + + IF GA22 /= ((1,1,1), (2,2,2), (1,1,1)) THEN + FAILED("INCORRECT VALUE OF GA22"); + END IF; + + IF GA23 /= ((1,1,1), (2,2,2), (1,1,1)) THEN + FAILED("INCORRECT VALUE OF GA23"); + END IF; + + IF GA24'LENGTH /= 0 OR GA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF GA24"); + END IF; + END GEN; + + PROCEDURE PROCG IS NEW GEN; + +BEGIN + TEST ("C43204H", "CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE " & + "CAN APPEAR AS A CONSTRAINED FORMAL PARAMETER " & + "OF A GENERIC UNIT, AND THAT THE BOUNDS OF " & + "THE AGGREGATE ARE DETERMINED CORRECTLY"); + + PROCG; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " & + "RAISED"); + + RESULT; +END C43204H; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43204i.ada b/gcc/testsuite/ada/acats/tests/c4/c43204i.ada new file mode 100644 index 000000000..1a761a541 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204i.ada @@ -0,0 +1,106 @@ +-- C43204I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE CAN APPEAR AS THE +-- EXPRESSION IN AN ASSIGNMENT STATEMENT, AND THAT THE BOUNDS OF +-- THE AGGREGATE ARE DETERMINED CORRECTLY. + +-- HISTORY: +-- JET 08/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43204I IS + + TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER; + TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER; + TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1, + INTEGER RANGE -1 .. 1) OF INTEGER; + TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1, + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + + VA11 : ARR11; + VA12 : ARR12; + VA13 : ARR13; + VA21 : ARR21; + VA22 : ARR22; + VA23 : ARR23; + VA24 : ARR24; + +BEGIN + TEST ("C43204I", "CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE " & + "CAN APPEAR AS THE EXPRESSION IN AN ASSIGNMENT " & + "STATEMENT, AND THAT THE BOUNDS OF THE " & + "AGGREGATE ARE DETERMINED CORRECTLY"); + + VA11 := (1,1, OTHERS => IDENT_INT(2)); + VA12 := (OTHERS => IDENT_INT(2)); + VA13 := (OTHERS => IDENT_INT(2)); + VA21 := ((1,1,1), OTHERS => (-1..1 => IDENT_INT(2))); + VA22 := (-1 => (1,1,1), 0..1 => (OTHERS => IDENT_INT(2))); + VA23 := (OTHERS => (OTHERS => IDENT_INT(2))); + VA24 := (OTHERS => (OTHERS => IDENT_INT(2))); + + IF VA11 /= (1, 1, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF VA11"); + END IF; + + IF VA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF VA12"); + END IF; + + IF VA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF VA13"); + END IF; + + IF VA21 /= ((1,1,1), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF VA21"); + END IF; + + IF VA22 /= ((1,1,1), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF VA22"); + END IF; + + IF VA23 /= ((2,2,2), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF VA23"); + END IF; + + IF VA24'LENGTH /= 0 OR VA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF VA24"); + END IF; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " & + "RAISED"); + + RESULT; +END C43204I; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205a.ada b/gcc/testsuite/ada/acats/tests/c4/c43205a.ada new file mode 100644 index 000000000..9946ba9ee --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205a.ada @@ -0,0 +1,111 @@ +-- C43205A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED +-- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY +-- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS: + +-- A) AN ACTUAL PARAMETER IN A SUBPROGRAM OR ENTRY CALL, AND THE +-- FORMAL PARAMETER IS UNCONSTRAINED. + +-- EG 01/26/84 + +WITH REPORT; + +PROCEDURE C43205A IS + + USE REPORT; + +BEGIN + + TEST("C43205A", "CASE A1 : SUBPROGRAM WITH UNCONSTRAINED " & + "ONE-DIMENSIONAL ARRAY FORMAL PARAMETER"); + + BEGIN + +CASE_A : BEGIN + + CASE_A1 : DECLARE + + SUBTYPE STA IS INTEGER RANGE 11 .. 15; + TYPE TA IS ARRAY (STA RANGE <>) OF INTEGER; + + PROCEDURE PROC1 (A : TA) IS + BEGIN + IF A'FIRST /= IDENT_INT(11) THEN + FAILED ("CASE A1 : LOWER BOUND " & + "INCORRECTLY GIVEN BY 'FIRST"); + ELSIF A'LAST /= 15 THEN + FAILED ("CASE A1 : UPPER BOUND " & + "INCORRECTLY GIVEN BY 'LAST"); + ELSIF A /= (6, 7, 8, 9, 10) THEN + FAILED ("CASE A1 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + BEGIN + + PROC1 ((6, 7, 8, 9, IDENT_INT(10))); + + END CASE_A1; + + COMMENT ("CASE A2 : SUBPROGRAM WITH UNCONSTRAINED " & + "TWO-DIMENSIONAL ARRAY FORMAL PARAMETER"); + + CASE_A2 : DECLARE + + SUBTYPE STA1 IS INTEGER RANGE 11 .. IDENT_INT(12); + SUBTYPE STA2 IS INTEGER RANGE 10 .. 11; + TYPE TA IS ARRAY (STA1 RANGE <>, STA2 RANGE <>) + OF INTEGER; + + PROCEDURE PROC1 (A : TA) IS + BEGIN + IF A'FIRST(1) /= 11 OR A'FIRST(2) /= 10 THEN + FAILED ("CASE A2 : LOWER BOUND " & + "INCORRECTLY GIVEN BY 'FIRST"); + ELSIF A'LAST(1) /= 12 OR + A'LAST(2) /= IDENT_INT(11) THEN + FAILED ("CASE A2 : UPPER BOUND " & + "INCORRECTLY GIVEN BY 'LAST"); + ELSIF A /= ((1, 2), (3, 4)) THEN + FAILED ("CASE A2 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + BEGIN + + PROC1 (((1, 2), (IDENT_INT(3), 4))); + + END CASE_A2; + + END CASE_A; + + END; + + RESULT; + +END C43205A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205b.ada b/gcc/testsuite/ada/acats/tests/c4/c43205b.ada new file mode 100644 index 000000000..7f4dfd6fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205b.ada @@ -0,0 +1,82 @@ +-- C43205B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED +-- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY +-- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS: + +-- B) AN ACTUAL PARAMETER IN A GENERIC INSTANTIATION, AND THE FORMAL +-- PARAMETER IS UNCONSTRAINED. + +-- EG 01/26/84 + +WITH REPORT; + +PROCEDURE C43205B IS + + USE REPORT; + +BEGIN + + TEST("C43205B", "CASE B : UNCONSTRAINED ARRAY FORMAL GENERIC " & + "PARAMETER"); + + BEGIN + +CASE_B : DECLARE + + SUBTYPE STB IS INTEGER RANGE IDENT_INT(-8) .. -5; + TYPE TB IS ARRAY (STB RANGE <>) OF INTEGER; + + GENERIC + B1 : TB; + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN + IF B1'FIRST /= -8 THEN + FAILED ("CASE B : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST"); + ELSIF B1'LAST /= IDENT_INT(-5) THEN + FAILED ("CASE B : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST"); + ELSIF B1 /= (7, 6, 5, 4) THEN + FAILED ("CASE B : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + PROCEDURE PROC2 IS NEW PROC1 ((7, 6, IDENT_INT(5), 4)); + + BEGIN + + PROC2; + + END CASE_B; + + END; + + RESULT; + +END C43205B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205c.ada b/gcc/testsuite/ada/acats/tests/c4/c43205c.ada new file mode 100644 index 000000000..e78837027 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205c.ada @@ -0,0 +1,83 @@ +-- C43205C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED +-- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY +-- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS: + +-- C) THE RETURN EXPRESSION IN A FUNCTION WHOSE RETURN TYPE IS +-- UNCONSTRAINED. + +-- EG 01/26/84 + +WITH REPORT; + +PROCEDURE C43205C IS + + USE REPORT; + +BEGIN + + TEST("C43205C", "CASE C : UNCONSTRAINED FUNCTION RESULT TYPE"); + + BEGIN + +CASE_C : DECLARE + + SUBTYPE STC1 IS INTEGER RANGE -2 .. 3; + SUBTYPE STC2 IS INTEGER RANGE 7 .. 20; + TYPE TC IS ARRAY (STC1 RANGE <>, STC2 RANGE <>) + OF INTEGER; + + FUNCTION FUN1 (A : INTEGER) RETURN TC IS + BEGIN + RETURN ((5, 4, 3), (2, IDENT_INT(1), 0)); + END; + + BEGIN + + IF FUN1(5)'FIRST(1) /= -2 THEN + FAILED ("CASE C : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST(1)"); + ELSIF FUN1(5)'FIRST(2) /= 7 THEN + FAILED ("CASE C : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST(2)"); + ELSIF FUN1(5)'LAST(1) /= -1 THEN + FAILED ("CASE C : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST(1)"); + ELSIF FUN1(5)'LAST(2) /= 9 THEN + FAILED ("CASE C : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST(2)"); + ELSIF FUN1(5) /= ((5, 4, 3), (2, 1, 0)) THEN + FAILED ("CASE C : FUNCTION DOES NOT " & + "RETURN THE CORRECT VALUES"); + END IF; + + END CASE_C; + + END; + + RESULT; + +END C43205C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205d.ada b/gcc/testsuite/ada/acats/tests/c4/c43205d.ada new file mode 100644 index 000000000..ddffcbe8a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205d.ada @@ -0,0 +1,73 @@ +-- C43205D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED +-- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY +-- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS: + +-- D) THE INITIALIZATION EXPRESSION OF A CONSTANT WHOSE TYPE MARK +-- DENOTES AN UNCONSTRAINED ARRAY. + +-- EG 01/26/84 + +WITH REPORT; + +PROCEDURE C43205D IS + + USE REPORT; + +BEGIN + + TEST("C43205D", "CASE D : INITIALIZATION OF UNCONSTRAINED " & + "ARRAY CONSTANT"); + + BEGIN + +CASE_D : DECLARE + + SUBTYPE STD IS INTEGER RANGE IDENT_INT(11) .. 13; + TYPE TD IS ARRAY (STD RANGE <>) OF INTEGER; + + D1 : CONSTANT TD := (-1, -2, -3); + + BEGIN + + IF D1'FIRST /= 11 THEN + FAILED ("CASE D : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST"); + ELSIF D1'LAST /= 13 THEN + FAILED ("CASE D : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST"); + ELSIF D1 /= (-1, -2, -3) THEN + FAILED ("CASE D : ARRAY DOES NOT CONTAIN " & + "THE CORRECT VALUES"); + END IF; + + END CASE_D; + + END; + + RESULT; + +END C43205D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205e.ada b/gcc/testsuite/ada/acats/tests/c4/c43205e.ada new file mode 100644 index 000000000..d06f209ae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205e.ada @@ -0,0 +1,117 @@ +-- C43205E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED +-- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY +-- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS: + +-- E) THE LEFT OR RIGHT OPERAND OF "&". + +-- EG 01/26/84 + +WITH REPORT; + +PROCEDURE C43205E IS + + USE REPORT; + +BEGIN + + TEST("C43205E", "CASE E : OPERAND OF &"); + + BEGIN + +CASE_E : DECLARE + + SUBTYPE STE IS INTEGER RANGE 2 .. 10; + + TYPE COLOR IS (RED, GREEN, BLUE); + TYPE TE IS ARRAY (STE RANGE <>) OF COLOR; + + FUNCTION CONCAT1 RETURN TE IS + BEGIN + RETURN (RED, GREEN, BLUE) & (7 .. 8 => RED); + END; + + FUNCTION CONCAT2 RETURN TE IS + BEGIN + RETURN (IDENT_INT(4) .. 3 => RED) & (GREEN, BLUE); + END; + + FUNCTION CONCAT3 RETURN STRING IS + BEGIN + RETURN "TEST" & (7 .. 8 => 'X'); + END; + + FUNCTION CONCAT4 RETURN STRING IS + BEGIN + RETURN (8 .. 5 => 'A') & "BC"; + END; + + BEGIN + + IF CONCAT1'FIRST /= IDENT_INT(2) THEN + FAILED ("CASE E1 : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST"); + ELSIF CONCAT1'LAST /= 6 THEN + FAILED ("CASE E1 : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST"); + ELSIF CONCAT1 /= (RED, GREEN, BLUE, RED, RED) THEN + FAILED ("CASE E1 : INCORRECT VALUES PRODUCED"); + END IF; + IF CONCAT2'FIRST /= IDENT_INT(2) THEN + FAILED ("CASE E2 : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST"); + ELSIF CONCAT2'LAST /= 3 THEN + FAILED ("CASE E2 : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST"); + ELSIF CONCAT2 /= (GREEN, BLUE) THEN + FAILED ("CASE E2 : INCORRECT VALUES PRODUCED"); + END IF; + IF CONCAT3'FIRST /= IDENT_INT(1) THEN + FAILED ("CASE E3 : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST"); + ELSIF CONCAT3'LAST /= 6 THEN + FAILED ("CASE E3 : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST"); + ELSIF CONCAT3 /= "TESTXX" THEN + FAILED ("CASE E3 : INCORRECT VALUES PRODUCED"); + END IF; + IF CONCAT4'FIRST /= IDENT_INT(1) THEN + FAILED ("CASE E4 : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST"); + ELSIF CONCAT4'LAST /= 2 THEN + FAILED ("CASE E4 : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST"); + ELSIF CONCAT4 /= "BC" THEN + FAILED ("CASE E4 : INCORRECT VALUES PRODUCED"); + END IF; + + END CASE_E; + + END; + + RESULT; + +END C43205E; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205g.ada b/gcc/testsuite/ada/acats/tests/c4/c43205g.ada new file mode 100644 index 000000000..54e0b743a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205g.ada @@ -0,0 +1,105 @@ +-- C43205G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED +-- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY +-- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE +-- POSITIONAL AGGREGATE IS USED AS: + +-- AN ACTUAL PARAMETER IN A SUBPROGRAM, AND THE +-- FORMAL PARAMETER IS CONSTRAINED. + +-- EG 01/27/84 + +WITH REPORT; + +PROCEDURE C43205G IS + + USE REPORT; + +BEGIN + + TEST("C43205G", "SUBPROGRAM WITH CONSTRAINED " & + "ONE-DIMENSIONAL ARRAY FORMAL PARAMETER"); + + BEGIN + +CASE_G : BEGIN + + CASE_G1 : DECLARE + + TYPE TA IS ARRAY (IDENT_INT(11) .. 15) OF INTEGER; + + PROCEDURE PROC1 (A : TA) IS + BEGIN + IF A'FIRST /= 11 THEN + FAILED ("CASE A1 : LOWER BOUND " & + "INCORRECT"); + ELSIF A'LAST /= 15 THEN + FAILED ("CASE A1 : UPPER BOUND " & + "INCORRECT"); + ELSIF A /= (6, 7, 8, 9, 10) THEN + FAILED ("CASE A1 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + BEGIN + + PROC1 ((6, 7, 8, IDENT_INT(9), 10)); + + END CASE_G1; + + CASE_G2 : DECLARE + + TYPE TA IS ARRAY (11 .. 12, + IDENT_INT(10) .. 11) OF INTEGER; + + PROCEDURE PROC1 (A : TA) IS + BEGIN + IF A'FIRST(1) /= 11 OR A'FIRST(2) /= 10 THEN + FAILED ("CASE A2 : LOWER BOUND " & + "INCORRECT"); + ELSIF A'LAST(1) /= 12 OR A'LAST(2) /= 11 THEN + FAILED ("CASE A2 : UPPER BOUND " & + "INCORRECT"); + ELSIF A /= ((1, 2), (3, 4)) THEN + FAILED ("CASE A2 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + BEGIN + + PROC1 (((1, 2), (3, 4))); + + END CASE_G2; + + END CASE_G; + + END; + + RESULT; + +END C43205G; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205h.ada b/gcc/testsuite/ada/acats/tests/c4/c43205h.ada new file mode 100644 index 000000000..9e4dc4ae0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205h.ada @@ -0,0 +1,82 @@ +-- C43205H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED +-- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY +-- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE +-- POSITIONAL AGGREGATE IS USED AS: + +-- AN ACTUAL PARAMETER IN A GENERIC INSTANTIATION, AND THE FORMAL +-- PARAMETER IS CONSTRAINED. + +-- EG 01/27/84 + +WITH REPORT; + +PROCEDURE C43205H IS + + USE REPORT; + +BEGIN + + TEST("C43205H", "CONSTRAINED ARRAY FORMAL GENERIC " & + "PARAMETER"); + + BEGIN + +CASE_H : DECLARE + + SUBTYPE STH IS INTEGER RANGE -10 .. 0; + TYPE BASE IS ARRAY(STH RANGE <>) OF INTEGER; + SUBTYPE TB IS BASE(IDENT_INT(-8) .. -5); + + GENERIC + B1 : TB; + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN + IF B1'FIRST /= -8 THEN + FAILED ("CASE B : LOWER BOUND INCORRECT"); + ELSIF B1'LAST /= -5 THEN + FAILED ("CASE B : UPPER BOUND INCORRECT"); + ELSIF B1 /= (7, 6, 5, 4) THEN + FAILED ("CASE B : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + PROCEDURE PROC2 IS NEW PROC1 ((7, 6, 5, 4)); + + BEGIN + + PROC2; + + END CASE_H; + + END; + + RESULT; + +END C43205H; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205i.ada b/gcc/testsuite/ada/acats/tests/c4/c43205i.ada new file mode 100644 index 000000000..44c255766 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205i.ada @@ -0,0 +1,83 @@ +-- C43205I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED +-- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY +-- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE +-- POSITIONAL AGGREGATE IS USED AS: + +-- THE RETURN EXPRESSION IN A FUNCTION WHOSE RETURN TYPE IS +-- CONSTRAINED. + +-- EG 01/27/84 + +WITH REPORT; + +PROCEDURE C43205I IS + + USE REPORT; + +BEGIN + + TEST("C43205I", "CONSTRAINED FUNCTION RESULT TYPE"); + + BEGIN + +CASE_I : DECLARE + + SUBTYPE STC IS INTEGER RANGE -2 .. 10; + TYPE BASE IS ARRAY(STC RANGE <>, STC RANGE <>)OF INTEGER; + SUBTYPE TC IS BASE(IDENT_INT(-1) .. 0, 7 .. 9); + + FUNCTION FUN1 (A : INTEGER) RETURN TC IS + BEGIN + RETURN ((5, 4, 3), (2, 1, 0)); + END; + + BEGIN + + IF FUN1(5)'FIRST(1) /= -1 THEN + FAILED ("CASE I : LOWER BOUND INCORRECT " & + "FOR 'FIRST(1)"); + ELSIF FUN1(5)'FIRST(2) /= 7 THEN + FAILED ("CASE I : LOWER BOUND INCORRECT " & + "FOR 'FIRST(2)"); + ELSIF FUN1(5)'LAST(1) /= 0 THEN + FAILED ("CASE I : UPPER BOUND INCORRECT " & + "FOR 'LAST(1)"); + ELSIF FUN1(5)'LAST(2) /= 9 THEN + FAILED ("CASE I : UPPER BOUND INCORRECT " & + "FOR 'LAST(2)"); + ELSIF FUN1(5) /= ((5, 4, 3), (2, 1, 0)) THEN + FAILED ("CASE I : FUNCTION DOES NOT " & + "RETURN THE CORRECT VALUES"); + END IF; + + END CASE_I; + + END; + + RESULT; + +END C43205I; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205j.ada b/gcc/testsuite/ada/acats/tests/c4/c43205j.ada new file mode 100644 index 000000000..946e074dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205j.ada @@ -0,0 +1,146 @@ +-- C43205J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED +-- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY +-- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE +-- POSITIONAL AGGREGATE IS USED AS: + +-- J) THE INITIALIZATION EXPRESSION OF A CONSTANT, VARIABLE, OR FORMAL +-- PARAMETER (OF A SUBPROGRAM, ENTRY, OR GENERIC UNIT) WHEN THE +-- TYPE OF THE CONSTANT, VARIABLE, OR PARAMETER IS CONSTRAINED. + +-- EG 01/27/84 + +WITH REPORT; + +PROCEDURE C43205J IS + + USE REPORT; + +BEGIN + + TEST("C43205J", "CASE J : INITIALIZATION OF CONSTRAINED " & + "ARRAY"); + + BEGIN + +CASE_J : BEGIN + + CASE_J1 : DECLARE + + TYPE TD1 IS ARRAY (IDENT_INT(11) .. 13) OF INTEGER; + + D1 : CONSTANT TD1 := (-1, -2, -3); + + BEGIN + + IF D1'FIRST /= 11 THEN + FAILED ("CASE J1 : LOWER BOUND INCORRECT"); + ELSIF D1'LAST /= 13 THEN + FAILED ("CASE J1 : UPPER BOUND INCORRECT"); + ELSIF D1 /= (-1, -2, -3) THEN + FAILED ("CASE J1 : ARRAY DOES NOT " & + "CONTAINING THE CORRECT VALUES"); + END IF; + + END CASE_J1; + + CASE_J2 : DECLARE + + TYPE TD2 IS ARRAY(INTEGER RANGE -13 .. -11) + OF INTEGER; + D2 : TD2 := (3, 2, 1); + + BEGIN + + IF D2'FIRST /= -13 THEN + FAILED ("CASE J2 : LOWER BOUND INCORRECT"); + ELSIF D2'LAST /= -11 THEN + FAILED ("CASE J2 : UPPER BOUND INCORRECT"); + ELSIF D2 /= (3, 2, 1) THEN + FAILED ("CASE J2 : INCORRECT VALUES"); + END IF; + + END CASE_J2; + + CASE_J3 : DECLARE + + TYPE TD3 IS ARRAY(IDENT_INT(5) .. 7) OF INTEGER; + + PROCEDURE PROC1 (A : TD3 := (2, 3, 4)) IS + BEGIN + IF A'FIRST /= 5 THEN + FAILED ("CASE J3 : LOWER BOUND " & + "INCORRECT"); + ELSIF A'LAST /= 7 THEN + FAILED ("CASE J3 : UPPER BOUND " & + "INCORRECT"); + ELSIF A /= (2, 3, 4) THEN + FAILED ("CASE J3 : INCORRECT VALUES"); + END IF; + END PROC1; + + BEGIN + + PROC1; + + END CASE_J3; + + CASE_J4 : DECLARE + + TYPE TD4 IS ARRAY(5 .. 8) OF INTEGER; + + GENERIC + D4 : TD4 := (1, -2, 3, -4); + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN + IF D4'FIRST /= 5 THEN + FAILED ("CASE J4 : LOWER BOUND " & + "INCORRECT"); + ELSIF D4'LAST /= 8 THEN + FAILED ("CASE J4 : UPPER BOUND " & + "INCORRECT"); + ELSIF D4 /= (1, -2, 3, -4) THEN + FAILED ("CASE J4 : INCORRECT VALUES"); + END IF; + END PROC1; + + PROCEDURE PROC2 IS NEW PROC1; + + BEGIN + + PROC2; + + END CASE_J4; + + END CASE_J; + + END; + + RESULT; + +END C43205J; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43205k.ada b/gcc/testsuite/ada/acats/tests/c4/c43205k.ada new file mode 100644 index 000000000..a3a712a44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205k.ada @@ -0,0 +1,110 @@ +-- C43205K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED +-- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY +-- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE +-- POSITIONAL AGGREGATE IS USED AS: + +-- THE EXPRESSION OF AN ENCLOSING RECORD OR ARRAY AGGREGATE, AND +-- THE EXPRESSION GIVES THE VALUE OF A RECORD OR ARRAY COMPONENT +-- (WHICH IS NECESSARILY CONSTRAINED). + +-- EG 01/27/84 +-- JBG 3/30/84 + +WITH REPORT; + +PROCEDURE C43205K IS + + USE REPORT; + +BEGIN + + TEST("C43205K", "THE EXPRESSION OF AN ENCLOSING RECORD " & + "OR ARRAY AGGREGATE, AND THE EXPRESSION GIVES " & + "THE VALUE OF A RECORD OR ARRAY COMPONENT"); + + BEGIN + +CASE_K : BEGIN + + CASE_K1 : DECLARE + + SUBTYPE SK1 IS INTEGER RANGE 2 .. 6; + TYPE BASE IS ARRAY(SK1 RANGE <>) OF INTEGER; + SUBTYPE TE1 IS BASE(IDENT_INT(3) .. 5); + TYPE TE2 IS ARRAY(1 .. 2) OF TE1; + + E1 : TE2; + + BEGIN + + E1 := (1 .. 2 => (3, 2, 1)); + IF (E1'FIRST /= 1 OR E1'LAST /= 2) OR ELSE + (E1(1)'FIRST /= 3 OR E1(1)'LAST /= 5 OR + E1(2)'FIRST /= 3 OR E1(2)'LAST /= 5) THEN + FAILED ("CASE K1 : INCORRECT BOUNDS"); + ELSE + IF E1 /= (1 .. 2 => (3, 2, 1)) THEN + FAILED ("CASE K1 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END IF; + + END CASE_K1; + + CASE_K2 : DECLARE + + TYPE SK2 IS RANGE 2 .. 6; + TYPE BASE IS ARRAY(SK2 RANGE <>) OF INTEGER; + SUBTYPE TE1 IS BASE(3 .. 5); + TYPE TER IS + RECORD + REC : TE1; + END RECORD; + + E2 : TER; + + BEGIN + + E2 := (REC => (3, 2, 1)); + IF E2.REC'FIRST /= 3 OR E2.REC'LAST /= 5 THEN + FAILED ("CASE K2 : INCORRECT BOUNDS"); + ELSE + IF E2.REC /= (3, 2, 1) THEN + FAILED ("CASE K2 : ARRAY DOES NOT " & + "CONTAIN CORRECT VALUES"); + END IF; + END IF; + + END CASE_K2; + + END CASE_K; + + END; + + RESULT; + +END C43205K; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43206a.ada b/gcc/testsuite/ada/acats/tests/c4/c43206a.ada new file mode 100644 index 000000000..af738920e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43206a.ada @@ -0,0 +1,242 @@ +-- C43206A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF A NULL ARRAY AGGREGATE ARE DETERMINED +-- BY THE BOUNDS SPECIFIED BY THE CHOICES. IN PARTICULAR, CHECK +-- THAT: + +-- A) THE UPPER BOUND IS NOT REQUIRED TO BE THE PREDECESSOR OF +-- THE LOWER BOUND. + +-- B) NEITHER THE UPPER NOR THE LOWER BOUND NEED BELONG TO THE +-- INDEX SUBTYPE FOR NULL RANGES. + +-- C) IF ONE CHOICE OF A MULTIDIMENSIONAL AGGREGATE IS NON-NULL +-- BUT THE AGGREGATE IS A NULL ARRAY, CONSTRAINT_ERROR IS +-- RAISED WHEN THE NON-NULL CHOICES DO NOT BELONG TO THE +-- INDEX SUBTYPE. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- EG 02/02/84 +-- JBG 12/6/84 +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; + +PROCEDURE C43206A IS + + USE REPORT; + +BEGIN + + TEST("C43206A", "CHECK THAT THE BOUNDS OF A NULL ARRAY ARE " & + "DETERMINED BY THE BOUNDS SPECIFIED BY THE " & + "CHOICES"); + + DECLARE + + SUBTYPE ST1 IS INTEGER RANGE 10 .. 15; + SUBTYPE ST2 IS INTEGER RANGE 1 .. 5; + + TYPE T1 IS ARRAY (ST1 RANGE <>) OF INTEGER; + TYPE T2 IS ARRAY (ST2 RANGE <>, ST1 RANGE <>) OF INTEGER; + + BEGIN + +CASE_A : BEGIN + + CASE_A1 : DECLARE + + PROCEDURE PROC1 (A : T1) IS + BEGIN + IF A'FIRST /= 12 OR A'LAST /= 10 THEN + FAILED ("CASE A1 : INCORRECT BOUNDS"); + END IF; + END PROC1; + + BEGIN + + PROC1((12 .. 10 => -2)); + + EXCEPTION + + WHEN OTHERS => + FAILED ("CASE A1 : EXCEPTION RAISED"); + + END CASE_A1; + + CASE_A2 : DECLARE + + PROCEDURE PROC1 (A : STRING) IS + BEGIN + IF A'FIRST /= 5 OR A'LAST /= 2 THEN + FAILED ("CASE A2 : INCORRECT BOUNDS"); + END IF; + END PROC1; + + BEGIN + + PROC1 ((5 .. 2 => 'E')); + + EXCEPTION + + WHEN OTHERS => + FAILED ("CASE A2 : EXCEPTION RAISED"); + + END CASE_A2; + + END CASE_A; + +CASE_B : BEGIN + + CASE_B1 : DECLARE + + PROCEDURE PROC1 (A : T1; L, U : INTEGER) IS + BEGIN + IF A'FIRST /= L OR A'LAST /= U THEN + FAILED ("CASE B1 : INCORRECT BOUNDS"); + END IF; + END PROC1; + + BEGIN + + BEGIN + + PROC1 ((5 .. INTEGER'FIRST => -2), + 5, INTEGER'FIRST); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("CASE B1A : CONSTRAINT_ERROR " & + "RAISED FOR NULL RANGE"); + WHEN OTHERS => + FAILED ("CASE B1A : EXCEPTION RAISED"); + + END; + + BEGIN + + PROC1 ((IDENT_INT(6) .. 3 => -2),6,3); + + EXCEPTION + + WHEN OTHERS => + FAILED ("CASE B1B : EXCEPTION RAISED"); + + END; + + END CASE_B1; + + CASE_B2 : DECLARE + + PROCEDURE PROC1 (A : STRING) IS + BEGIN + IF A'FIRST /= 1 OR + A'LAST /= INTEGER'FIRST THEN + FAILED ("CASE B2 : INCORRECT BOUNDS"); + END IF; + END PROC1; + + BEGIN + + PROC1 ((1 .. INTEGER'FIRST => ' ')); + + EXCEPTION + + WHEN OTHERS => + FAILED ("CASE B2 : EXCEPTION RAISED"); + + END CASE_B2; + + END CASE_B; + +CASE_C : BEGIN + + CASE_C1 : DECLARE + + PROCEDURE PROC1 (A : T2) IS + BEGIN + IF A'FIRST(1) /= 5 OR A'LAST(1) /= 3 OR + A'FIRST(2) /= INTEGER'LAST-1 OR + A'LAST(2) /= INTEGER'LAST THEN + FAILED ("CASE C1 : INCORRECT BOUNDS"); + END IF; + END PROC1; + + BEGIN + + PROC1 ((5 .. 3 => + (IDENT_INT(INTEGER'LAST-1) .. + IDENT_INT(INTEGER'LAST) => -2))); + FAILED ("CASE C1 : CONSTRAINT_ERROR NOT RAISED"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("CASE C1 : EXCEPTION RAISED"); + + END CASE_C1; + + CASE_C2 : DECLARE + + PROCEDURE PROC1 (A : T2) IS + BEGIN + IF A'FIRST(1) /= INTEGER'FIRST OR + A'LAST(1) /= INTEGER'FIRST+1 OR + A'FIRST(2) /= 14 OR A'LAST(2) /= 11 THEN + FAILED ("CASE C2 : INCORRECT BOUNDS"); + END IF; + END PROC1; + + BEGIN + + PROC1 ((IDENT_INT(INTEGER'FIRST) .. + IDENT_INT(INTEGER'FIRST+1) => + (14 .. IDENT_INT(11) => -2))); + FAILED ("CASE C2 : CONSTRAINT_ERROR NOT RAISED"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("CASE C2 : EXCEPTION RAISED"); + + END CASE_C2; + + END CASE_C; + + END; + + RESULT; + +END C43206A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43207b.ada b/gcc/testsuite/ada/acats/tests/c4/c43207b.ada new file mode 100644 index 000000000..197a9155e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43207b.ada @@ -0,0 +1,149 @@ +-- C43207B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM (F..G => (H..I => J)), +-- CHECK THAT: + +-- B) IF H..I IS A NULL RANGE, CONSTRAINT_ERROR IS RAISED IF +-- F..G IS NON-NULL AND F OR G DO NOT BELONG TO THE INDEX +-- SUBTYPE; + +-- EG 01/18/84 +-- BHS 7/13/84 +-- JBG 12/6/84 + +WITH REPORT; + +PROCEDURE C43207B IS + + USE REPORT; + +BEGIN + + TEST("C43207B", "CHECK THAT THE EVALUATION OF A MULTI" & + "DIMENSIONAL AGGREGATE OF THE FORM " & + "(F..G => (H..I = J)) IS PERFORMED " & + "CORRECTLY"); + + DECLARE + + TYPE CHOICE_INDEX IS (F, G, H, I, J); + TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER; + + CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0); + + SUBTYPE SINT IS INTEGER RANGE 1 .. 8; + TYPE T0 IS ARRAY(SINT RANGE <>, SINT RANGE <>) OF INTEGER; + + FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER) + RETURN INTEGER IS + BEGIN + CNTR(A) := CNTR(A) + 1; + RETURN IDENT_INT(B); + END CALC; + + BEGIN + +CASE_B : DECLARE + PROCEDURE CHECK (A : T0; M : STRING) IS + BEGIN + IF (A'FIRST(1) /= 1) OR (A'LAST(1) /= 9) OR + (A'FIRST(2) /= 6) OR (A'LAST(2) /= 5) THEN + FAILED("CASE B" & M & " : ARRAY NOT " & + "BOUNDED CORRECTLY"); + END IF; + END CHECK; + BEGIN + + CASE_B1 : BEGIN + CHECK ((1 .. 9 => (6 .. 5 => 2)),"1"); + FAILED ("CASE B1 : CONSTRAINT_ERROR NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("CASE B1 : EXCEPTION RAISED"); + END CASE_B1; + + CASE_B2 : BEGIN + CHECK ((CALC(F,1) .. CALC(G,9) => (6 .. 5 => 2)), + "2"); + FAILED ("CASE B2 : CONSTRAINT_ERROR NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("CASE B2 : EXCEPTION RAISED"); + END CASE_B2; + + CASE_B3 : BEGIN + CHECK ((1 .. 9 => (CALC(H,6) .. CALC(I,5) => 2)), + "3"); + FAILED ("CASE B3 : CONSTRAINT_ERROR NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("CASE B3 : EXCEPTION RAISED"); + END CASE_B3; + + END CASE_B; + + IF CNTR(F) /= 1 THEN + FAILED ("CASE B2 : F WAS NOT EVALUATED " & + "ONCE. F WAS EVALUATED" & + INTEGER'IMAGE(CNTR(F)) & " TIMES"); + END IF; + IF CNTR(G) /= 1 THEN + FAILED ("CASE B2 : G WAS NOT EVALUATED " & + "ONCE. G WAS EVALUATED" & + INTEGER'IMAGE(CNTR(G)) & " TIMES"); + END IF; + + IF CNTR(H) /= 0 AND CNTR(I) /= 0 THEN + COMMENT ("CASE B3 : ALL CHOICES " & + "EVALUATED BEFORE CHECKING " & + "INDEX SUBTYPE"); + ELSIF CNTR(H) = 0 AND CNTR(I) = 0 THEN + COMMENT ("CASE B3 : SUBTYPE CHECKS "& + "MADE AS CHOICES ARE EVALUATED"); + END IF; + + IF CNTR(H) > 1 THEN + FAILED("CASE B3 : H WAS NOT EVALUATED " & + "AT MOST ONCE. H WAS EVALUATED" & + INTEGER'IMAGE(CNTR(H)) & " TIMES"); + END IF; + + IF CNTR(I) > 1 THEN + FAILED("CASE B3 : I WAS NOT EVALUATED " & + "AT MOST ONCE. I WAS EVALUATED" & + INTEGER'IMAGE(CNTR(I)) & " TIMES"); + END IF; + + END; + + RESULT; + +END C43207B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43207d.ada b/gcc/testsuite/ada/acats/tests/c4/c43207d.ada new file mode 100644 index 000000000..5733ec8fa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43207d.ada @@ -0,0 +1,135 @@ +-- C43207D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM (F..G => (H..I => J)), +-- CHECK THAT: + +-- D) J IS EVALUATED ONCE FOR EACH COMPONENT (ZERO TIMES IF THE +-- ARRAY IS NULL). + +-- EG 01/18/84 + +WITH REPORT; + +PROCEDURE C43207D IS + + USE REPORT; + +BEGIN + + TEST("C43207D", "CHECK THAT THE EVALUATION OF A MULTI" & + "DIMENSIONAL AGGREGATE OF THE FORM " & + "(F..G => (H..I = J)) IS PERFORMED " & + "CORRECTLY"); + + DECLARE + + TYPE CHOICE_INDEX IS (F, G, H, I, J); + TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER; + + CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0); + + SUBTYPE SINT IS INTEGER RANGE 1 .. 8; + TYPE T0 IS ARRAY(SINT RANGE <>, SINT RANGE <>) OF INTEGER; + + FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER) + RETURN INTEGER IS + BEGIN + CNTR(A) := CNTR(A) + 1; + RETURN IDENT_INT(B); + END CALC; + + BEGIN + +CASE_D : BEGIN + + CASE_D1 : DECLARE + D1 : T0(8 .. 4, 5 .. 1); + BEGIN + CNTR := (CHOICE_INDEX => 0); + D1 := (8 .. 4 => (5 .. 1 => CALC(J,2))); + IF CNTR(J) /= 0 THEN + FAILED("CASE D1 : INCORRECT NUMBER " & + "OF EVALUATIONS. J EVALUATED" & + INTEGER'IMAGE(CNTR(J)) & " TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE D1 : EXCEPTION RAISED"); + END CASE_D1; + + CASE_D2 : DECLARE + D2 : T0(8 .. 4, 5 .. 1); + BEGIN + CNTR := (CHOICE_INDEX => 0); + D2 := (CALC(F,8) .. CALC(G,4) => + (CALC(H,5) .. CALC(I,1) => CALC(J,2))); + IF CNTR(J) /= 0 THEN + FAILED("CASE D2 : INCORRECT NUMBER " & + "OF EVALUATIONS. J EVALUATED" & + INTEGER'IMAGE(CNTR(J)) & " TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE D2 : EXCEPTION RAISED"); + END CASE_D2; + + CASE_D3 : DECLARE + D3 : T0(3 .. 5, 1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + D3 := (3 .. 5 => (1 .. 2 => CALC(J,2))); + IF CNTR(J) /= 6 THEN + FAILED("CASE D3 : INCORRECT NUMBER " & + "OF EVALUATIONS. J EVALUATED" & + INTEGER'IMAGE(CNTR(J)) & " TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE D3 : EXCEPTION RAISED"); + END CASE_D3; + + CASE_D4 : DECLARE + D4 : T0(1 .. 2, 5 .. 7); + BEGIN + CNTR := (CHOICE_INDEX => 0); + D4 := (CALC(F,1) .. CALC(G,2) => + (CALC(H,5) .. CALC(I,7) => CALC(J,2))); + IF CNTR(J) /= 6 THEN + FAILED("CASE D4 : INCORRECT NUMBER " & + "OF EVALUATIONS. J EVALUATED" & + INTEGER'IMAGE(CNTR(J)) & " TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE D4 : EXCEPTION RAISED"); + END CASE_D4; + + END CASE_D; + + END; + + RESULT; + +END C43207D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43208a.ada b/gcc/testsuite/ada/acats/tests/c4/c43208a.ada new file mode 100644 index 000000000..c04a395ea --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43208a.ada @@ -0,0 +1,208 @@ +-- C43208A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR A ONE-DIMENSIONAL AGGREGATE OF THE FORM (F..G => (H..I => J)), +-- CHECK THAT: + +-- A) IF F..G IS A NULL RANGE, H, I, AND J ARE NOT EVALUATED. + +-- B) IF F..G IS A NON-NULL RANGE, H AND I ARE EVALUATED G-F+1 +-- TIMES, AND J IS EVALUATED (I-H+1)*(G-F+1) TIMES IF H..I +-- IS NON-NULL. + +-- EG 01/19/84 + +WITH REPORT; + +PROCEDURE C43208A IS + + USE REPORT; + +BEGIN + + TEST("C43208A", "CHECK THAT THE EVALUATION OF A ONE-" & + "DIMENSIONAL AGGREGATE OF THE FORM " & + "(F..G => (H..I = J)) IS PERFORMED " & + "CORRECTLY"); + + DECLARE + + TYPE CHOICE_INDEX IS (F, G, H, I, J); + TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER; + + CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0); + + TYPE T1 IS ARRAY(INTEGER RANGE <>) OF INTEGER; + + FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER) + RETURN INTEGER IS + BEGIN + CNTR(A) := CNTR(A) + 1; + RETURN IDENT_INT(B); + END CALC; + + BEGIN + +CASE_A : BEGIN + + CASE_A1 : DECLARE + A1 : ARRAY(4 .. 2) OF T1(1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + A1 := (4 .. 2 => + (CALC(H,1) .. CALC(I,2) => CALC(J,2))); + IF CNTR(H) /= 0 THEN + FAILED("CASE A1 : H WAS EVALUATED"); + END IF; + IF CNTR(I) /= 0 THEN + FAILED("CASE A1 : I WAS EVALUATED"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE A1 : J WAS EVALUATED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE A1 : EXCEPTION RAISED"); + END CASE_A1; + + CASE_A2 : DECLARE + A2 : ARRAY(4 .. 2) OF T1(1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + A2 := (CALC(F,4) .. CALC(G,2) => + (CALC(H,1) .. CALC(I,2) => CALC(J,2))); + IF CNTR(H) /= 0 THEN + FAILED("CASE A2 : H WAS EVALUATED"); + END IF; + IF CNTR(I) /= 0 THEN + FAILED("CASE A2 : I WAS EVALUATED"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE A2 : J WAS EVALUATED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE A2 : EXCEPTION RAISED"); + END CASE_A2; + + END CASE_A; + +CASE_B : BEGIN + + CASE_B1 : DECLARE + B1 : ARRAY(2 .. 3) OF T1(1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B1 := (2 .. 3 => + (CALC(H,1) .. CALC(I,2) => CALC(J,2))); + IF CNTR(H) /= 2 THEN + FAILED("CASE B1 : H NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(I) /= 2 THEN + FAILED("CASE B1 : I NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(J) /= 4 THEN + FAILED("CASE B1 : J NOT EVALUATED (I-H+1)*" & + "(G-F+1) TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B1 : EXECEPTION RAISED"); + END CASE_B1; + + CASE_B2 : DECLARE + B2 : ARRAY(2 .. 3) OF T1(9 .. 10); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B2 := (CALC(F,2) .. CALC(G,3) => + (CALC(H,9) .. CALC(I,10) => CALC(J,2))); + IF CNTR(H) /= 2 THEN + FAILED("CASE B2 : H NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(I) /= 2 THEN + FAILED("CASE B2 : I NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(J) /= 4 THEN + FAILED("CASE B2 : J NOT EVALUATED (I-H+1)*" & + "(G-F+1) TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B2 : EXECEPTION RAISED"); + END CASE_B2; + + CASE_B3 : DECLARE + B3 : ARRAY(2 .. 3) OF T1(2 .. 1); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B3 := (2 .. 3 => + (CALC(H,2) .. CALC(I,1) => CALC(J,2))); + IF CNTR(H) /= 2 THEN + FAILED("CASE B3 : H NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(I) /= 2 THEN + FAILED("CASE B3 : I NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE B3 : J NOT EVALUATED ZERO TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B3 : EXECEPTION RAISED"); + END CASE_B3; + + CASE_B4 : DECLARE + B4 : ARRAY(2 .. 3) OF T1(2 .. 1); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B4 := (CALC(F,2) .. CALC(G,3) => + (CALC(H,2) .. CALC(I,1) => CALC(J,2))); + IF CNTR(H) /= 2 THEN + FAILED("CASE B4 : H NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(I) /= 2 THEN + FAILED("CASE B4 : I NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE B4 : J NOT EVALUATED ZERO TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B4 : EXECEPTION RAISED"); + END CASE_B4; + + END CASE_B; + END; + + RESULT; + +END C43208A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43208b.ada b/gcc/testsuite/ada/acats/tests/c4/c43208b.ada new file mode 100644 index 000000000..de5ac5fd1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43208b.ada @@ -0,0 +1,266 @@ +-- C43208B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR AN AGGREGATE OF THE FORM: +-- (B..C => (D..E => (F..G => (H..I => J)))) +-- WHOSE TYPE IS A TWO-DIMENSIONAL ARRAY TYPE THAT HAS A TWO- +-- DIMENSIONAL ARRAY COMPONENT TYPE, CHECK THAT: + +-- A) IF B..C OR D..E IS A NULL RANGE, THEN F, G, H, I, AND J +-- ARE NOT EVALUATED. + +-- B) IF B..C AND D..E ARE NON-NULL RANGES, THEN F, G, H AND I +-- ARE EVALUATED (C-B+1)*(E-D+1) TIMES, AND J IS EVALUATED +-- (C-B+1)*(E-D+1)*(G-F+1)*(I-H+1) TIMES IF F..G AND H..I +-- ARE NON-NULL. + +-- EG 01/19/84 + +WITH REPORT; + +PROCEDURE C43208B IS + + USE REPORT; + +BEGIN + + TEST("C43208B", "CHECK THAT THE EVALUATION OF A MULTI" & + "DIMENSIONAL ARRAY TYPE THAT HAS AN " & + "ARRAY COMPONENT TYPE IS PERFORMED " & + "CORRECTLY"); + + DECLARE + + TYPE CHOICE_INDEX IS (B, C, D, E, F, G, H, I, J); + TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER; + + CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0); + + TYPE T1 IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) + OF INTEGER; + + FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER) + RETURN INTEGER IS + BEGIN + CNTR(A) := CNTR(A) + 1; + RETURN IDENT_INT(B); + END CALC; + + BEGIN + +CASE_A : BEGIN + + CASE_A1 : DECLARE + A1 : ARRAY(4 .. 3, 3 .. 4) OF T1(2 .. 3, 1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + A1 := (4 .. 3 => (3 .. 4 => + (CALC(F,2) .. CALC(G,3) => + (CALC(H,1) .. CALC(I,2) => CALC(J,2))))); + IF CNTR(F) /= 0 THEN + FAILED("CASE A1 : F WAS EVALUATED"); + END IF; + IF CNTR(G) /= 0 THEN + FAILED("CASE A1 : G WAS EVALUATED"); + END IF; + IF CNTR(H) /= 0 THEN + FAILED("CASE A1 : H WAS EVALUATED"); + END IF; + IF CNTR(I) /= 0 THEN + FAILED("CASE A1 : I WAS EVALUATED"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE A1 : J WAS EVALUATED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE A1 : EXCEPTION RAISED"); + END CASE_A1; + + CASE_A2 : DECLARE + A2 : ARRAY(3 .. 4, 4 .. 3) OF T1(2 .. 3, 1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + A2 := (CALC(B,3) .. CALC(C,4) => + (CALC(D,4) .. CALC(E,3) => + (CALC(F,2) .. CALC(G,3) => + (CALC(H,1) .. CALC(I,2) => CALC(J,2))))); + IF CNTR(F) /= 0 THEN + FAILED("CASE A2 : F WAS EVALUATED"); + END IF; + IF CNTR(G) /= 0 THEN + FAILED("CASE A2 : G WAS EVALUATED"); + END IF; + IF CNTR(H) /= 0 THEN + FAILED("CASE A2 : H WAS EVALUATED"); + END IF; + IF CNTR(I) /= 0 THEN + FAILED("CASE A2 : I WAS EVALUATED"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE A2 : J WAS EVALUATED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE A2 : EXCEPTION RAISED"); + END CASE_A2; + + END CASE_A; + +CASE_B : BEGIN + + CASE_B1 : DECLARE + B1 : ARRAY(2 .. 3, 1 .. 2) OF T1(1 .. 2, 9 .. 10); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B1 := (2 .. 3 => (1 .. 2 => + (CALC(F,1) .. CALC(G,2) => + (CALC(H,9) .. CALC(I,10) => CALC(J,2))))); + IF CNTR(F) /= 4 THEN + FAILED("CASE B1 : F NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(G) /= 4 THEN + FAILED("CASE B1 : G NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(H) /= 4 THEN + FAILED("CASE B1 : H NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(I) /= 4 THEN + FAILED("CASE B1 : I NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(J) /= 16 THEN + FAILED("CASE B1 : J NOT EVALUATED (C-B+1)*" & + "(E-D+1)*(G-F+1)*(I-H+1) TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B1 : EXECEPTION RAISED"); + END CASE_B1; + + CASE_B2 : DECLARE + B2 : ARRAY(2 .. 3, 1 .. 2) OF T1(1 .. 2, 9 .. 10); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B2 := (CALC(B,2) .. CALC(C,3) => + (CALC(D,1) .. CALC(E,2) => + (CALC(F,1) .. CALC(G,2) => + (CALC(H,9) .. CALC(I,10) => CALC(J,2))))); + IF CNTR(F) /= 4 THEN + FAILED("CASE B2 : F NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(G) /= 4 THEN + FAILED("CASE B2 : G NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(H) /= 4 THEN + FAILED("CASE B2 : H NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(I) /= 4 THEN + FAILED("CASE B2 : I NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(J) /= 16 THEN + FAILED("CASE B2 : J NOT EVALUATED (C-B+1)*" & + "(E-D+1)*(G-F+1)*(I-H+1) TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B2 : EXECEPTION RAISED"); + END CASE_B2; + + CASE_B3 : DECLARE + B3 : ARRAY(2 .. 3, 1 .. 2) OF T1(1 .. 2, 2 .. 1); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B3 := (2 .. 3 => (1 .. 2 => + (CALC(F,1) .. CALC(G,2) => + (CALC(H,2) .. CALC(I,1) => CALC(J,2))))); + IF CNTR(F) /= 4 THEN + FAILED("CASE B3 : F NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(G) /= 4 THEN + FAILED("CASE B3 : G NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(H) /= 4 THEN + FAILED("CASE B3 : H NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(I) /= 4 THEN + FAILED("CASE B3 : I NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE B3 : J NOT EVALUATED ZERO TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B3 : EXECEPTION RAISED"); + END CASE_B3; + + CASE_B4 : DECLARE + B4 : ARRAY(2 .. 3, 1 .. 2) OF T1(2 .. 1, 1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B4 := (CALC(B,2) .. CALC(C,3) => + (CALC(D,1) .. CALC(E,2) => + (CALC(F,2) .. CALC(G,1) => + (CALC(H,1) .. CALC(I,2) => CALC(J,2))))); + IF CNTR(F) /= 4 THEN + FAILED("CASE B4 : F NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(G) /= 4 THEN + FAILED("CASE B4 : G NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(H) /= 4 THEN + FAILED("CASE B4 : H NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(I) /= 4 THEN + FAILED("CASE B4 : I NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE B4 : J NOT EVALUATED ZERO TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B4 : EXECEPTION RAISED"); + END CASE_B4; + + END CASE_B; + END; + + RESULT; + +END C43208B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43209a.ada b/gcc/testsuite/ada/acats/tests/c4/c43209a.ada new file mode 100644 index 000000000..c86d9494c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43209a.ada @@ -0,0 +1,135 @@ +-- C43209A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT A STRING LITERAL IS ALLOWED IN A MULTIDIMENSIONAL +-- ARRAY AGGREGATE AT THE PLACE OF A ONE DIMENSIONAL ARRAY OF +-- CHARACTER TYPE. + +-- HISTORY: +-- DHH 08/12/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43209A IS + + TYPE MULTI_ARRAY IS ARRAY(1 .. 2, 1 .. 3, 1 .. 6) OF CHARACTER; + +BEGIN + TEST("C43209A", "CHECK THAT A STRING LITERAL IS ALLOWED IN A " & + "MULTIDIMENSIONAL ARRAY AGGREGATE AT THE PLACE " & + "OF A ONE DIMENSIONAL ARRAY OF CHARACTER TYPE"); + + DECLARE + X : MULTI_ARRAY := ((('A', 'B', 'C', 'D', 'E', 'F'), + ('G', 'H', 'I', 'J', 'K', 'L'), + ('M', 'N', 'O', 'P', 'Q', 'R')), + (('S', 'T', 'U', 'V', 'W', 'X'), + ('W', 'Z', 'A', 'B', 'C', 'D'), + "WHOZAT")); + + Y : MULTI_ARRAY := (("WHOZAT", + ('A', 'B', 'C', 'D', 'E', 'F'), + ('G', 'H', 'I', 'J', 'K', 'L')), + (('M', 'N', 'O', 'P', 'Q', 'R'), + ('S', 'T', 'U', 'V', 'W', 'X'), + ('W', 'Z', 'A', 'B', 'C', 'D'))); + + BEGIN + IF X(IDENT_INT(2), IDENT_INT(3), IDENT_INT(6)) /= + Y(IDENT_INT(1), IDENT_INT(1), IDENT_INT(6)) THEN + FAILED("INITIALIZATION FAILURE"); + END IF; + END; + + DECLARE + PROCEDURE FIX_AGG(T : MULTI_ARRAY) IS + BEGIN + IF T(IDENT_INT(2), IDENT_INT(2), IDENT_INT(5)) /= + T(IDENT_INT(1), IDENT_INT(1), IDENT_INT(1)) THEN + FAILED("SUBPROGRAM FAILURE"); + END IF; + END; + BEGIN + FIX_AGG((("WHOZAT", ('A', 'B', 'C', 'D', 'E', 'F'), + ('G', 'H', 'I', 'J', 'K', 'L')), + (('M', 'N', 'O', 'P', 'Q', 'R'), + ('S', 'T', 'U', 'V', 'W', 'X'), + ('W', 'Z', 'A', 'B', 'C', 'D')))); + + END; + + DECLARE + + Y : CONSTANT MULTI_ARRAY := (("WHOZAT", + ('A', 'B', 'C', 'D', 'E', 'F'), + ('G', 'H', 'I', 'J', 'K', 'L')), + (('M', 'N', 'O', 'P', 'Q', 'R'), + ('S', 'T', 'U', 'V', 'W', 'X'), + ('W', 'Z', 'A', 'B', 'C', 'D'))); + + BEGIN + IF Y(IDENT_INT(2), IDENT_INT(2), IDENT_INT(5)) /= + Y(IDENT_INT(1), IDENT_INT(1), IDENT_INT(1)) THEN + FAILED("CONSTANT FAILURE"); + END IF; + END; + + DECLARE + BEGIN + IF MULTI_ARRAY'((1 =>(('A', 'B', 'C', 'D', 'E', 'F'), + ('G', 'H', 'I', 'J', 'K', 'L'), + ('M', 'N', 'O', 'P', 'Q', 'R')), + 2 => (('S', 'T', 'U', 'V', 'W', 'X'), + ('W', 'Z', 'A', 'B', 'C', 'D'), + "WHOZAT"))) = MULTI_ARRAY'((1 =>(1 =>"WHOZAT", + 2 =>('A', 'B', 'C', 'D', 'E', 'F'), + 3 =>('G', 'H', 'I', 'J', 'K', 'L')), + 2 => (1 =>('M', 'N', 'O', 'P', 'Q', 'R'), + 2 =>('S', 'T', 'U', 'V', 'W', 'X'), + 3 => ('W', 'Z', 'A', 'B', 'C', 'D')))) THEN + FAILED("EQUALITY OPERATOR FAILURE"); + END IF; + END; + + DECLARE + SUBTYPE SM IS INTEGER RANGE 1 .. 10; + TYPE UNCONSTR IS ARRAY(SM RANGE <>, SM RANGE<>) OF CHARACTER; + + FUNCTION FUNC(X : SM) RETURN UNCONSTR IS + BEGIN + IF EQUAL(X,X) THEN + RETURN (1 => "WHEN", 2 => "WHAT"); + ELSE + RETURN (" ", " "); + END IF; + END FUNC; + + BEGIN + IF FUNC(1) /= FUNC(2) THEN + FAILED("UNCONSTRAINED FUNCTION RETURN FAILURE"); + END IF; + END; + + RESULT; +END C43209A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43210a.ada b/gcc/testsuite/ada/acats/tests/c4/c43210a.ada new file mode 100644 index 000000000..549021e60 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43210a.ada @@ -0,0 +1,142 @@ +-- C43210A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A NON-AGGREGATE EXPRESSION IN A NAMED COMPONENT +-- ASSOCIATION IS EVALUATED ONCE FOR EACH COMPONENT SPECIFIED +-- BY THE ASSOCIATION. + +-- EG 02/02/84 + +WITH REPORT; + +PROCEDURE C43210A IS + + USE REPORT; + +BEGIN + + TEST("C43210A", "CHECK THAT A NON-AGGREGATE IN A NAMED " & + "COMPONENT ASSOCIATION IS EVALUATED ONCE " & + "FOR EACH COMPONENT SPECIFIED BY THE " & + "ASSOCIATION"); + + DECLARE + + TYPE T1 IS ARRAY(1 .. 10) OF INTEGER; + TYPE T2 IS ARRAY(1 .. 8, 1 .. 2) OF INTEGER; + TYPE T3 IS ARRAY(1 .. 2, 1 .. 8) OF INTEGER; + TYPE T4 IS ARRAY(1 .. 8, 1 .. 8) OF INTEGER; + + A1 : T1; + A2 : T2; + A3 : T3; + A4 : T4; + CC : INTEGER; + + FUNCTION CALC (A : INTEGER) RETURN INTEGER IS + BEGIN + CC := CC + 1; + RETURN IDENT_INT(A); + END CALC; + + PROCEDURE CHECK (A : STRING; B : INTEGER) IS + BEGIN + IF CC /= B THEN + FAILED ("CASE " & A & " : INCORRECT NUMBER OF " & + "EVALUATIONS. NUMBER OF EVALUATIONS " & + "SHOULD BE " & INTEGER'IMAGE(B) & + ", BUT IS " & INTEGER'IMAGE(CC)); + END IF; + END CHECK; + + BEGIN + +CASE_A : BEGIN + + CC := 0; + A1 := T1'(4 .. 5 => CALC(2), 6 .. 8 => CALC(4), + OTHERS => 5); + CHECK ("A", 5); + + END CASE_A; + +CASE_B : BEGIN + + CC := 0; + A1 := T1'(1 | 4 .. 6 | 3 | 2 => CALC(-1), OTHERS => -2); + CHECK ("B", 6); + + END CASE_B; + +CASE_C : BEGIN + + CC := 0; + A1 := T1'(1 | 3 | 5 | 7 .. 9 => -1, OTHERS => CALC(-2)); + CHECK ("C", 4); + + END CASE_C; + +CASE_D : BEGIN + + CC := 0; + A2 := T2'(4 .. 6 | 8 | 2 .. 3 => (1 .. 2 => CALC(1)), + OTHERS => (1 .. 2 => -1)); + CHECK ("D", 12); + + END CASE_D; + +CASE_E : BEGIN + + CC := 0; + A3 := T3'(1 .. 2 => (2 | 4 | 6 .. 8 => CALC(-1), + OTHERS => -2)); + CHECK ("E", 10); + + END CASE_E; + +CASE_F : BEGIN + + CC := 0; + A4 := T4'(7 .. 8 | 3 .. 5 => + (1 | 2 | 4 | 6 .. 8 => CALC(1), OTHERS => -2), + OTHERS => (OTHERS => -2)); + CHECK ("F", 30); + + END CASE_F; + +CASE_G : BEGIN + + CC := 0; + A4 := T4'(5 .. 8 | 3 | 1 => (7 | 1 .. 5 | 8 => -1, + OTHERS => CALC(-2)), + OTHERS => (OTHERS => CALC(-2))); + CHECK ("G", 22); + + END CASE_G; + + END; + + RESULT; + +END C43210A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43211a.ada b/gcc/testsuite/ada/acats/tests/c4/c43211a.ada new file mode 100644 index 000000000..cf745d0dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43211a.ada @@ -0,0 +1,170 @@ +-- C43211A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF A BOUND IN A NON-NULL +-- RANGE OF A NON-NULL AGGREGATE DOES NOT BELONG TO THE INDEX SUBTYPE. + +-- EG 02/06/84 +-- EG 05/08/85 +-- EDS 07/15/98 AVOID OPTIMIZATION + +WITH REPORT; + +PROCEDURE C43211A IS + + USE REPORT; + +BEGIN + + TEST("C43211A","CHECK THAT CONSTRAINT_ERROR IS RAISED IF A " & + "BOUND IN A NON-NULL RANGE OF A NON-NULL " & + "AGGREGATE DOES NOT BELONG TO THE INDEX " & + "SUBTYPE"); + + DECLARE + + SUBTYPE ST IS INTEGER RANGE 4 .. 8; + TYPE BASE IS ARRAY(ST RANGE <>, ST RANGE <>) OF INTEGER; + SUBTYPE T IS BASE(5 .. 7, 5 .. 7); + + A : T; + + BEGIN + +CASE_A : BEGIN + + A := (6 .. 8 => (4 .. 6 => 0)); + IF A /= (6 .. 8 => (4 .. 6 => 0)) THEN + FAILED ("CASE A : INCORRECT VALUES"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED: CASE A"); + + END CASE_A; + +CASE_B : BEGIN + + A := (6 .. IDENT_INT(8) => + (IDENT_INT(4) .. 6 => 1)); + IF A /= (6 .. IDENT_INT(8) => + (IDENT_INT(4) .. 6 => 1)) THEN + FAILED ("CASE B : INCORRECT VALUES"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED: CASE B"); + + END CASE_B; + +CASE_C : BEGIN + + A := (7 .. 9 => (5 .. 7 => IDENT_INT(2))); + FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE C " & + INTEGER'IMAGE(A(IDENT_INT(7),7))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED: CASE C"); + + END CASE_C; + +CASE_D : BEGIN + + A := (5 .. 7 => (3 .. 5 => IDENT_INT(3))); + FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE D " & + INTEGER'IMAGE(A(7,IDENT_INT(5)))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED: CASE D"); + + END CASE_D; + +CASE_E : BEGIN + + A := (7 .. IDENT_INT(9) => (5 .. 7 => IDENT_INT(4))); + FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE E " & + INTEGER'IMAGE(A(IDENT_INT(7),7))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("CASE E : EXCEPTION RAISED"); + + END CASE_E; + +CASE_F : BEGIN + + A := (5 .. 7 => (IDENT_INT(3) .. 5 => IDENT_INT(5))); + FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE F " & + INTEGER'IMAGE(A(7,IDENT_INT(5)))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED: CASE F"); + + END CASE_F; + +CASE_G : BEGIN + + A := (7 .. 8 => (5 .. 7 => IDENT_INT(6)), + 9 => (5 .. 7 => IDENT_INT(6))); + FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE G " & + INTEGER'IMAGE(A(7,IDENT_INT(7)))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED: CASE G"); + + END CASE_G; + + END; + + RESULT; + +END C43211A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43212a.ada b/gcc/testsuite/ada/acats/tests/c4/c43212a.ada new file mode 100644 index 000000000..fd940332e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43212a.ada @@ -0,0 +1,154 @@ +-- C43212A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF ALL SUBAGGREGATES FOR A +-- PARTICULAR DIMENSION DO NOT HAVE THE SAME BOUNDS. + +-- EG 02/06/1984 +-- JBG 3/30/84 +-- JRK 4/18/86 CORRECTED ERROR TO ALLOW CONSTRAINT_ERROR TO BE +-- RAISED EARLIER. +-- EDS 7/15/98 AVOID OPTIMIZATION. + +WITH REPORT; + +PROCEDURE C43212A IS + + USE REPORT; + +BEGIN + + TEST ("C43212A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF ALL " & + "SUBAGGREGATES FOR A PARTICULAR DIMENSION DO " & + "NOT HAVE THE SAME BOUNDS"); + + DECLARE + + TYPE CHOICE_INDEX IS (H, I); + TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER; + + CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0); + + FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER) + RETURN INTEGER IS + BEGIN + CNTR(A) := CNTR(A) + 1; + RETURN IDENT_INT(B); + END CALC; + + BEGIN + +CASE_1 : DECLARE + + TYPE T IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) + OF INTEGER; + + A1 : T(1 .. 3, 2 .. 5) := (OTHERS => (OTHERS => 0)); + + BEGIN + + CNTR := (CHOICE_INDEX => 0); + A1 := (1 => (CALC(H,2) .. CALC(I,5) => -4), + 2 => (CALC(H,3) .. CALC(I,6) => -5), + 3 => (CALC(H,2) .. CALC(I,5) => -3)); + FAILED ("CASE 1 : CONSTRAINT_ERROR NOT RAISED" & + INTEGER'IMAGE(A1(1,5)) ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + IF CNTR(H) < 2 AND CNTR(I) < 2 THEN + FAILED ("CASE 1 : BOUNDS OF SUBAGGREGATES " & + "NOT DETERMINED INDEPENDENTLY"); + END IF; + + WHEN OTHERS => + FAILED ("CASE 1 : WRONG EXCEPTION RAISED"); + + END CASE_1; + +CASE_1A : DECLARE + + TYPE T IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) + OF INTEGER; + + A1 : T(1 .. 3, 2 .. 3) := (1 .. 3 => (2 .. 3 => 1)); + + BEGIN + + IF (1 .. 2 => (IDENT_INT(3) .. IDENT_INT(4) => 0), + 3 => (1, 2)) = A1 THEN + BEGIN + COMMENT(" IF SHOULD GENERATE CONSTRAINT_ERROR " & + INTEGER'IMAGE(A1(1,2)) ); + EXCEPTION + WHEN OTHERS => + FAILED ("CASE 1A : CONSTRAINT_ERROR NOT RAISED"); + END; + END IF; + FAILED ("CASE 1A : CONSTRAINT_ERROR NOT RAISED"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("CASE 1A : WRONG EXCEPTION RAISED"); + + END CASE_1A; + +CASE_2 : DECLARE + + TYPE T IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) + OF INTEGER; + + A2 : T(1 .. 3, IDENT_INT(4) .. 2); + + BEGIN + + CNTR := (CHOICE_INDEX => 0); + A2 := (1 => (CALC(H,5) .. CALC(I,3) => -4), + 3 => (CALC(H,4) .. CALC(I,2) => -5), + 2 => (CALC(H,4) .. CALC(I,2) => -3)); + FAILED ("CASE 2 : CONSTRAINT_ERROR NOT RAISED " & + INTEGER'IMAGE(IDENT_INT(A2'FIRST(1)))); + EXCEPTION + + WHEN CONSTRAINT_ERROR => + IF CNTR(H) < 2 AND CNTR(I) < 2 THEN + FAILED ("CASE 2 : BOUNDS OF SUBAGGREGATES " & + "NOT DETERMINED INDEPENDENTLY"); + END IF; + + WHEN OTHERS => + FAILED ("CASE 2 : WRONG EXCEPTION RAISED"); + + END CASE_2; + + END; + + RESULT; + +END C43212A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43212c.ada b/gcc/testsuite/ada/acats/tests/c4/c43212c.ada new file mode 100644 index 000000000..30764670e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43212c.ada @@ -0,0 +1,102 @@ +-- C43212C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF ALL SUBAGGREGATES FOR +-- A PARTICULAR DIMENSION DO NOT HAVE THE SAME BOUNDS. +-- ADDITIONAL CASES FOR THE THIRD DIMENSION AND FOR THE NULL ARRAYS. + +-- PK 02/21/84 +-- EG 05/30/84 + +WITH REPORT; +USE REPORT; + +PROCEDURE C43212C IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + +BEGIN + + TEST("C43212C","CHECK THAT CONSTRAINT_ERROR IS RAISED IF ALL " & + "SUBAGGREGATES FOR A PARTICULAR DIMENSION DO " & + "NOT HAVE THE SAME BOUNDS"); + + DECLARE + TYPE A3 IS ARRAY(INT RANGE <>, INT RANGE <>, INT RANGE <>) + OF INTEGER; + BEGIN + IF A3'(((IDENT_INT(1) .. IDENT_INT(2) => IDENT_INT(1)), + (1 .. IDENT_INT(2) => IDENT_INT(1))), + ((IDENT_INT(2) .. IDENT_INT(3) => IDENT_INT(1)), + (IDENT_INT(2) .. IDENT_INT(3) => IDENT_INT(1)))) + = + A3'(((IDENT_INT(1) .. IDENT_INT(2) => IDENT_INT(1)), + (1 .. IDENT_INT(2) => IDENT_INT(1))), + ((IDENT_INT(2) .. IDENT_INT(3) => IDENT_INT(1)), + (IDENT_INT(2) .. IDENT_INT(3) => IDENT_INT(1)))) + THEN + FAILED ("A3 - EXCEPTION NOT RAISED, ARRAYS EQUAL"); + END IF; + FAILED ("A3 - EXCEPTION NOT RAISED, ARRAYS NOT EQUAL"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("A3 - WRONG EXCEPTION RAISED"); + + END; + + DECLARE + + TYPE B3 IS ARRAY(INT RANGE <>, INT RANGE <>, INT RANGE <>) + OF INTEGER; + + BEGIN + + IF B3'(((IDENT_INT(2) .. IDENT_INT(1) => IDENT_INT(1)), + (2 .. IDENT_INT(1) => IDENT_INT(1))), + ((IDENT_INT(3) .. IDENT_INT(1) => IDENT_INT(1)), + (IDENT_INT(3) .. IDENT_INT(1) => IDENT_INT(1)))) + = + B3'(((IDENT_INT(2) .. IDENT_INT(1) => IDENT_INT(1)), + (2 .. IDENT_INT(1) => IDENT_INT(1))), + ((IDENT_INT(3) .. IDENT_INT(1) => IDENT_INT(1)), + (IDENT_INT(3) .. IDENT_INT(1) => IDENT_INT(1)))) + THEN + FAILED ("B3 - EXCEPTION NOT RAISED, ARRAYS EQUAL"); + END IF; + FAILED ("B3 - EXCEPTION NOT RAISED, ARRAYS NOT EQUAL"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("B3 - WRONG EXCEPTION RAISED"); + + END; + + RESULT; + +END C43212C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43214a.ada b/gcc/testsuite/ada/acats/tests/c4/c43214a.ada new file mode 100644 index 000000000..6d953c4d7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43214a.ada @@ -0,0 +1,100 @@ +-- C43214A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM (F..G => ""), CHECK +-- THAT CONSTRAINT_ERROR IS RAISED IF F..G IS NON-NULL AND +-- F OR G DO NOT BELONG TO THE INDEX SUBTYPE. + +-- EG 02/10/1984 +-- JBG 12/6/84 +-- EDS 07/15/98 AVOID OPTIMIZATION + +WITH REPORT; + +PROCEDURE C43214A IS + + USE REPORT; + +BEGIN + + TEST("C43214A", "FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM " & + "(F..G => """"), CHECK THAT CONSTRAINT ERROR " & + "IS RAISED IF F..G IS NON-NULL AND NOT IN THE " & + "INDEX SUBTYPE"); + + DECLARE + + SUBTYPE STA IS INTEGER RANGE 4 .. 7; + TYPE TA IS ARRAY(STA RANGE 5 .. 6, + STA RANGE 6 .. IDENT_INT(4)) OF CHARACTER; + + A : TA := (5 .. 6 => ""); + + BEGIN + +CASE_A : BEGIN + + IF (6 .. IDENT_INT(8) => "") = A THEN + FAILED ("CASE A : CONSTRAINT_ERROR NOT RAISED"); + END IF; + FAILED ("CASE A : CONSTRAINT_ERROR NOT RAISED - 2"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("CASE A : WRONG EXCEPTION RAISED"); + + END CASE_A; + +CASE_B : BEGIN + + A := (IDENT_INT(3) .. 4 => ""); + FAILED ("CASE B : CONSTRAINT_ERROR NOT RAISED"); + BEGIN + FAILED("ATTEMPT TO USE A " & + CHARACTER'VAL(IDENT_INT(CHARACTER'POS( + A(A'FIRST(1), A'FIRST(2)) ))) ); + EXCEPTION + WHEN OTHERS => + FAILED("CONSTRAINT_ERROR NOT RAISED AT PROPER PLACE"); + END; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("CASE B : WRONG EXCEPTION RAISED"); + + END CASE_B; + + END; + + RESULT; + +END C43214A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43214b.ada b/gcc/testsuite/ada/acats/tests/c4/c43214b.ada new file mode 100644 index 000000000..6db7e2b9d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43214b.ada @@ -0,0 +1,105 @@ +-- C43214B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY +-- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS. + +-- EG 02/10/84 + +WITH REPORT; + +PROCEDURE C43214B IS + + USE REPORT; + +BEGIN + + TEST("C43214B", "SUBPROGRAM WITH CONSTRAINED ARRAY FORMAL " & + "PARAMETER"); + + BEGIN + +CASE_A : BEGIN + +-- COMMENT ("CASE A1 : SUBPROGRAM WITH CONSTRAINED " & +-- "ONE-DIMENSIONAL ARRAY FORMAL PARAMETER"); + + CASE_A1 : DECLARE + + SUBTYPE STA1 IS STRING(IDENT_INT(11) .. 15); + + PROCEDURE PROC1 (A : STA1) IS + BEGIN + IF A'FIRST /= 11 THEN + FAILED ("CASE 1 : LOWER BOUND " & + "INCORRECT"); + ELSIF A'LAST /= 15 THEN + FAILED ("CASE 1 : UPPER BOUND " & + "INCORRECT"); + ELSIF A /= "ABCDE" THEN + FAILED ("CASE 1 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + BEGIN + + PROC1 ("ABCDE"); + + END CASE_A1; + +-- COMMENT ("CASE A2 : SUBPROGRAM WITH CONSTRAINED " & +-- "TWO-DIMENSIONAL ARRAY FORMAL PARAMETER"); + + CASE_A2 : DECLARE + + TYPE TA IS ARRAY (11 .. 12, 10 .. 11) OF CHARACTER; + + PROCEDURE PROC1 (A : TA) IS + BEGIN + IF A'FIRST(1) /= 11 OR A'FIRST(2) /= 10 THEN + FAILED ("CASE 2 : LOWER BOUND " & + "INCORRECT"); + ELSIF A'LAST(1) /= 12 OR A'LAST(2) /= 11 THEN + FAILED ("CASE 2 : UPPER BOUND " & + "INCORRECT"); + ELSIF A /= ("AB", "CD") THEN + FAILED ("CASE 2 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + BEGIN + + PROC1 (("AB", "CD")); + + END CASE_A2; + + END CASE_A; + + END; + + RESULT; + +END C43214B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43214c.ada b/gcc/testsuite/ada/acats/tests/c4/c43214c.ada new file mode 100644 index 000000000..b5233022f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43214c.ada @@ -0,0 +1,75 @@ +-- C43214C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY +-- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS. + +-- EG 02/10/84 + +WITH REPORT; + +PROCEDURE C43214C IS + + USE REPORT; + +BEGIN + + TEST("C43214C", "CONSTRAINED ARRAY FORMAL GENERIC " & + "PARAMETER"); + + BEGIN + +CASE_B : DECLARE + + SUBTYPE STB IS STRING(5 .. 8); + + GENERIC + B1 : STB; + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN + IF B1'FIRST /= 5 THEN + FAILED ("LOWER BOUND INCORRECT"); + ELSIF B1'LAST /= 8 THEN + FAILED ("UPPER BOUND INCORRECT"); + ELSIF B1 /= "ABCD" THEN + FAILED ("ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + PROCEDURE PROC2 IS NEW PROC1 ("ABCD"); + + BEGIN + + PROC2; + + END CASE_B; + + END; + + RESULT; + +END C43214C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43214d.ada b/gcc/testsuite/ada/acats/tests/c4/c43214d.ada new file mode 100644 index 000000000..7274a4b46 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43214d.ada @@ -0,0 +1,77 @@ +-- C43214D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY +-- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS. + +-- EG 02/10/84 + +WITH REPORT; + +PROCEDURE C43214D IS + + USE REPORT; + +BEGIN + + TEST("C43214D", "CONSTRAINED FUNCTION RESULT TYPE"); + + BEGIN + +CASE_C : DECLARE + + TYPE TC IS ARRAY (INTEGER RANGE -1 .. 0, + IDENT_INT(7) .. 9) OF CHARACTER; + + FUNCTION FUN1 (A : INTEGER) RETURN TC IS + BEGIN + RETURN ("ABC", "DEF"); + END; + + BEGIN + + IF FUN1(5)'FIRST(1) /= -1 THEN + FAILED ("LOWER BOUND INCORRECT " & + "FOR 'FIRST(1)"); + ELSIF FUN1(5)'FIRST(2) /= 7 THEN + FAILED ("LOWER BOUND INCORRECT " & + "FOR 'FIRST(2)"); + ELSIF FUN1(5)'LAST(1) /= 0 THEN + FAILED ("UPPER BOUND INCORRECT " & + "FOR 'LAST(1)"); + ELSIF FUN1(5)'LAST(2) /= 9 THEN + FAILED ("UPPER BOUND INCORRECT " & + "FOR 'LAST(2)"); + ELSIF FUN1(5) /= ("ABC", "DEF") THEN + FAILED ("FUNCTION DOES NOT " & + "RETURN THE CORRECT VALUES"); + END IF; + + END CASE_C; + + END; + + RESULT; + +END C43214D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43214e.ada b/gcc/testsuite/ada/acats/tests/c4/c43214e.ada new file mode 100644 index 000000000..88ebb510b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43214e.ada @@ -0,0 +1,147 @@ +-- C43214E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY +-- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS. + +-- EG 02/10/84 + +WITH REPORT; + +PROCEDURE C43214E IS + + USE REPORT; + +BEGIN + + TEST("C43214E", "INITIALIZATION OF CONSTRAINED ARRAY"); + + BEGIN + +CASE_D : BEGIN + +-- COMMENT ("CASE D1 : INITIALIZATION OF CONSTRAINED " & +-- "ARRAY CONSTANT"); + + CASE_D1 : DECLARE + + D1 : CONSTANT STRING(11 .. 13) := "ABC"; + + BEGIN + + IF D1'FIRST /= 11 THEN + FAILED ("CASE 1 : LOWER BOUND INCORRECT"); + ELSIF D1'LAST /= 13 THEN + FAILED ("CASE 1 : UPPER BOUND INCORRECT"); + ELSIF D1 /= "ABC" THEN + FAILED ("CASE 1 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + + END CASE_D1; + +-- COMMENT ("CASE D2 : INITIALIZATION OF CONSTRAINED " & +-- "ARRAY VARIABLE"); + + CASE_D2 : DECLARE + + D2 : STRING(11 .. 13) := "ABC"; + + BEGIN + + IF D2'FIRST /= 11 THEN + FAILED ("CASE 2 : LOWER BOUND INCORRECT"); + ELSIF D2'LAST /= 13 THEN + FAILED ("CASE 2 : UPPER BOUND INCORRECT"); + ELSIF D2 /= "ABC" THEN + FAILED ("CASE 2 : INCORRECT VALUES"); + END IF; + + END CASE_D2; + +-- COMMENT ("CASE D3 : INITIALIZATION OF CONSTRAINED " & +-- "ARRAY FORMAL PARAMETER OF A SUBPROGRAM"); + + CASE_D3 : DECLARE + + SUBTYPE STD3 IS STRING(IDENT_INT(5) .. 7); + + PROCEDURE PROC1 (A : STD3 := "ABC") IS + BEGIN + IF A'FIRST /= 5 THEN + FAILED ("CASE 3 : LOWER BOUND " & + "INCORRECT"); + ELSIF A'LAST /= 7 THEN + FAILED ("CASE 3 : UPPER BOUND " & + "INCORRECT"); + ELSIF A /= "ABC" THEN + FAILED ("CASE 3 : INCORRECT VALUES"); + END IF; + END PROC1; + + BEGIN + + PROC1; + + END CASE_D3; + +-- COMMENT ("CASE D4 : INITIALIZATION OF CONSTRAINED " & +-- "ARRAY FORMAL PARAMETER OF A GENERIC UNIT"); + + CASE_D4 : DECLARE + + SUBTYPE STD4 IS STRING(5 .. 8); + + GENERIC + D4 : STD4 := "ABCD"; + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN + IF D4'FIRST /= 5 THEN + FAILED ("CASE 4 : LOWER BOUND " & + "INCORRECT"); + ELSIF D4'LAST /= 8 THEN + FAILED ("CASE 4 : UPPER BOUND " & + "INCORRECT"); + ELSIF D4 /= "ABCD" THEN + FAILED ("CASE 4 : INCORRECT VALUES"); + END IF; + END PROC1; + + PROCEDURE PROC2 IS NEW PROC1; + + BEGIN + + PROC2; + + END CASE_D4; + + END CASE_D; + + END; + + RESULT; + +END C43214E; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43214f.ada b/gcc/testsuite/ada/acats/tests/c4/c43214f.ada new file mode 100644 index 000000000..2c19d1748 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43214f.ada @@ -0,0 +1,151 @@ +-- C43214F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY +-- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS. + +-- EG 02/10/84 +-- JBG 3/30/84 + +WITH REPORT; + +PROCEDURE C43214F IS + + USE REPORT; + +BEGIN + + TEST("C43214F", "ARRAY COMPONENT EXPRESSION OF AN ENCLOSING " & + "AGGREGATE"); + + BEGIN + +CASE_E : BEGIN + +-- COMMENT ("CASE E1 : ARRAY COMPONENT EXPRESSION OF " & +-- "AN ENCLOSING ARRAY AGGREGATE"); + + CASE_E1 : DECLARE + + TYPE TE2 IS ARRAY(1 .. 2) OF + STRING(IDENT_INT(3) .. 5); + + E1 : TE2; + + BEGIN + + E1 := (1 .. 2 => "ABC"); + IF (E1'FIRST /= 1 OR E1'LAST /= 2) OR ELSE + (E1(1)'FIRST /= 3 OR E1(1)'LAST /= 5 OR + E1(2)'FIRST /= 3 OR E1(2)'LAST /= 5) THEN + FAILED ("CASE 1 : INCORRECT BOUNDS"); + ELSIF E1 /= (1 .. 2 => "ABC") THEN + FAILED ("CASE 1 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + + END CASE_E1; + +-- COMMENT ("CASE E2 : ARRAY COMPONENT EXPRESSION OF " & +-- "AN ENCLOSING RECORD AGGREGATE"); + + CASE_E2 : DECLARE + + TYPE TER IS + RECORD + REC : STRING(3 .. 5); + END RECORD; + + E2 : TER; + + BEGIN + + E2 := (REC => "ABC"); + IF E2.REC'FIRST /= 3 OR E2.REC'LAST /= 5 THEN + FAILED ("CASE 2 : INCORRECT BOUNDS"); + ELSIF E2.REC /= "ABC" THEN + FAILED ("CASE 2 : ARRAY DOES NOT " & + "CONTAIN CORRECT VALUES"); + END IF; + + END CASE_E2; + +-- COMMENT ("CASE E3 : NULL LITERAL OF AN ENCLOSING " & +-- "ARRAY AGGREGATE"); + + CASE_E3 : DECLARE + + TYPE TE2 IS ARRAY(1 .. 2) OF + STRING(3 .. IDENT_INT(2)); + + E3 : TE2; + + BEGIN + + E3 := (1 .. 2 => ""); + IF (E3'FIRST /= 1 OR E3'LAST /= 2) OR ELSE + (E3(1)'FIRST /= 3 OR E3(1)'LAST /= 2 OR + E3(2)'FIRST /= 3 OR E3(2)'LAST /= 2) THEN + FAILED ("CASE 3 : INCORRECT BOUND"); + ELSIF E3 /= (1 .. 2 => "") THEN + FAILED ("CASE 3 : ARRAY DOES NOT CONTAIN " & + "THE CORRECT VALUES"); + END IF; + + END CASE_E3; + +-- COMMENT ("CASE E4 : ARRAY COMPONENT EXPRESSION OF " & +-- "AN ENCLOSING RECORD AGGREGATE THAT HAS A " & +-- "DISCRIMINANT AND THE DISCRIMINANT DETER" & +-- "MINES THE BOUNDS OF THE COMPONENT"); + + CASE_E4 : DECLARE + + SUBTYPE TEN IS INTEGER RANGE 1 .. 10; + TYPE TER (A : TEN) IS + RECORD + REC : STRING(3 .. A); + END RECORD; + + E4 : TER(5); + + BEGIN + + E4 := (REC => "ABC", A => 5); + IF E4.REC'FIRST /= 3 OR E4.REC'LAST /= 5 THEN + FAILED ("CASE 4 : INCORRECT BOUNDS"); + ELSIF E4.REC /= "ABC" THEN + FAILED ("CASE 4 : ARRAY DOES NOT CONTAIN " & + "CORRECT VALUES"); + END IF; + + END CASE_E4; + + END CASE_E; + + END; + + RESULT; + +END C43214F; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43215a.ada b/gcc/testsuite/ada/acats/tests/c4/c43215a.ada new file mode 100644 index 000000000..ff832cc2a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43215a.ada @@ -0,0 +1,138 @@ +-- C43215A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A POSITIONAL +-- ARRAY AGGREGATE WHOSE UPPER BOUND EXCEEDS THE UPPER BOUND +-- OF THE INDEX SUBTYPE BUT BELONGS TO THE INDEX BASE TYPE. + +-- EG 02/13/84 + +WITH REPORT; +WITH SYSTEM; + +PROCEDURE C43215A IS + + USE REPORT; + USE SYSTEM; + +BEGIN + + TEST("C43215A","CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "FOR A POSITIONAL ARRAY AGGREGATE WHOSE " & + "UPPER BOUND EXCEEDS THE UPPER BOUND OF THE " & + "INDEX SUBTYPE BUT BELONGS TO THE INDEX " & + "BASE TYPE"); + + BEGIN + +CASE_A : DECLARE + + LOWER_BOUND : CONSTANT := MAX_INT-3; + UPPER_BOUND : CONSTANT := MAX_INT-1; + + TYPE STA IS RANGE LOWER_BOUND .. UPPER_BOUND; + + TYPE TA IS ARRAY(STA RANGE <>) OF INTEGER; + + A1 : TA(STA); + OK : EXCEPTION; + + FUNCTION FUN1 RETURN TA IS + BEGIN + RETURN (1, 2, 3, 4); + EXCEPTION + WHEN CONSTRAINT_ERROR => + BEGIN + COMMENT ("CASE A : CONSTRAINT_ERROR RAISED"); + RAISE OK; + END; + WHEN OTHERS => + BEGIN + FAILED ("CASE A : EXCEPTION RAISED IN FUN1"); + RAISE OK; + END; + END FUN1; + + BEGIN + + A1 := FUN1; + FAILED ("CASE A : CONSTRAINT_ERROR NOT RAISED"); + + EXCEPTION + + WHEN OK => + NULL; + + WHEN OTHERS => + FAILED ("CASE A : EXCEPTION RAISED"); + + END CASE_A; + +CASE_B : DECLARE + + TYPE ENUM IS (A, B, C, D); + + SUBTYPE STB IS ENUM RANGE A .. C; + + TYPE TB IS ARRAY(STB RANGE <>) OF INTEGER; + + B1 : TB(STB); + OK : EXCEPTION; + + FUNCTION FUN1 RETURN TB IS + BEGIN + RETURN (1, 2, 3, 4); + EXCEPTION + WHEN CONSTRAINT_ERROR => + BEGIN + COMMENT ("CASE B : CONSTRAINT_ERROR RAISED"); + RAISE OK; + END; + WHEN OTHERS => + BEGIN + FAILED ("CASE B : EXCEPTION RAISED IN FUN1"); + RAISE OK; + END; + END FUN1; + + BEGIN + + B1 := FUN1; + FAILED ("CASE B : CONSTRAINT_ERROR NOT RAISED"); + + EXCEPTION + + WHEN OK => + NULL; + + WHEN OTHERS => + FAILED ("CASE B : EXCEPTION RAISED"); + + END CASE_B; + + END; + + RESULT; + +END C43215A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43215b.ada b/gcc/testsuite/ada/acats/tests/c4/c43215b.ada new file mode 100644 index 000000000..a80f818f2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43215b.ada @@ -0,0 +1,142 @@ +-- C43215B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE UPPER BOUND +-- OF A POSITIONAL AGGREGATE DOES NOT BELONG TO THE INDEX BASE TYPE. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- EG 02/13/84 +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; +WITH SYSTEM; + +PROCEDURE C43215B IS + + USE REPORT; + USE SYSTEM; + +BEGIN + + TEST("C43215B","CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "WHEN THE UPPER BOUND OF A POSITIONAL ARRAY " & + "AGGREGATE DOES NOT BELONG TO THE INDEX " & + "BASE TYPE"); + + BEGIN + +CASE_A : DECLARE + + LOWER_BOUND : CONSTANT := MAX_INT-3; + UPPER_BOUND : CONSTANT := MAX_INT-1; + + TYPE STA IS RANGE LOWER_BOUND .. UPPER_BOUND; + + TYPE TA IS ARRAY(STA RANGE <>) OF INTEGER; + + A1 : TA(STA); + OK : EXCEPTION; + + FUNCTION FUN1 RETURN TA IS + BEGIN + RETURN (1, 2, 3, 4, 5); + EXCEPTION + WHEN CONSTRAINT_ERROR => + BEGIN + COMMENT ("CASE A : CONSTRAINT_ERROR RAISED"); + RAISE OK; + END; + WHEN OTHERS => + BEGIN + FAILED ("CASE A : EXCEPTION RAISED IN FUN1"); + RAISE OK; + END; + END FUN1; + + BEGIN + + A1 := FUN1; + FAILED ("CASE A : CONSTRAINT OR NUMERIC ERROR WAS " & + "NOT RAISED"); + + EXCEPTION + + WHEN OK => + NULL; + + WHEN OTHERS => + FAILED ("CASE A : WRONG EXCEPTION RAISED"); + + END CASE_A; + +CASE_B : DECLARE + + TYPE ENUM IS (A, B, C, D); + + SUBTYPE STB IS ENUM RANGE A .. C; + + TYPE TB IS ARRAY(STB RANGE <>) OF INTEGER; + + B1 : TB(STB); + OK : EXCEPTION; + + FUNCTION FUN1 RETURN TB IS + BEGIN + RETURN (1, 2, 3, 4, 5); + EXCEPTION + WHEN CONSTRAINT_ERROR => + BEGIN + COMMENT ("CASE B : CONSTRAINT_ERROR RAISED"); + RAISE OK; + END; + WHEN OTHERS => + BEGIN + FAILED ("CASE B : EXCEPTION RAISED IN FUN1"); + RAISE OK; + END; + END FUN1; + + BEGIN + + B1 := FUN1; + FAILED ("CASE B : CONSTRAINT ERROR WAS NOT RAISED"); + + EXCEPTION + + WHEN OK => + NULL; + + WHEN OTHERS => + FAILED ("CASE B : WRONG EXCEPTION RAISED"); + + END CASE_B; + + END; + + RESULT; + +END C43215B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43222a.ada b/gcc/testsuite/ada/acats/tests/c4/c43222a.ada new file mode 100644 index 000000000..f1056576f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43222a.ada @@ -0,0 +1,49 @@ +-- C43222A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN ARRAY AGGREGATE NEED NOT BE RESOLVABLE TO A +-- CONSTRAINED SUBTYPE. + +-- HISTORY: +-- DHH 08/12/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43222A IS + +BEGIN + TEST("C43222A", "CHECK THAT AN ARRAY AGGREGATE NEED NOT BE " & + "RESOLVABLE TO A CONSTRAINED SUBTYPE"); + + DECLARE + TYPE A IS ARRAY(INTEGER RANGE <>) OF INTEGER; + B : BOOLEAN := (1, 2, 3) = A'(1, 2, 3); + BEGIN + IF IDENT_BOOL(B) /= IDENT_BOOL(TRUE) THEN + FAILED("INITIALIZATION FAILURE"); + END IF; + END; + + RESULT; +END C43222A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c43224a.ada b/gcc/testsuite/ada/acats/tests/c4/c43224a.ada new file mode 100644 index 000000000..799309a82 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43224a.ada @@ -0,0 +1,75 @@ +-- C43224A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT A NON-STATIC CHOICE OF AN ARRAY AGGREGATE CAN BE A +-- 'RANGE ATTRIBUTE. + +-- HISTORY: +-- DHH 08/15/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C43224A IS + + M, O : INTEGER := IDENT_INT(2); + N : INTEGER := IDENT_INT(3); + + TYPE ARR IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE D3_ARR IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>, + INTEGER RANGE <>) OF INTEGER; + + SUBTYPE ARR1 IS ARR(IDENT_INT(2) .. IDENT_INT(3)); + SUBTYPE ARR2 IS D3_ARR(1 .. M, 1 .. N, 1 ..O); + + SUB : ARR1; + SUB1 : ARR2; + + PROCEDURE PROC(ARRY : IN OUT ARR) IS + BEGIN + ARRY := (ARR1'RANGE => IDENT_INT(7)); + IF ARRY(IDENT_INT(ARRY'FIRST)) /= IDENT_INT(7) THEN + FAILED("RANGE NOT INITIALIZED - 1"); + END IF; + END PROC; + + PROCEDURE PROC1(ARRY : IN OUT D3_ARR) IS + BEGIN + ARRY := (ARR2'RANGE(1) => (ARRY'RANGE(2) => + (ARRY'RANGE(3) => IDENT_INT(7)))); + + IF ARRY(IDENT_INT(1), IDENT_INT(2), IDENT_INT(1)) /= + IDENT_INT(7) THEN + FAILED("RANGE NOT INITIALIZED - 2"); + END IF; + END PROC1; + +BEGIN + TEST("C43224A", "CHECK THAT A NON-STATIC CHOICE OF AN ARRAY " & + "AGGREGATE CAN BE A 'RANGE ATTRIBUTE"); + + PROC(SUB); + PROC1(SUB1); + + RESULT; +END C43224A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c433001.a b/gcc/testsuite/ada/acats/tests/c4/c433001.a new file mode 100644 index 000000000..613b688c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c433001.a @@ -0,0 +1,302 @@ +-- C433001.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 an others choice is allowed in an array aggregate whose +-- applicable index constraint is dynamic. (This was an extension to +-- Ada 83). Check that index choices are within the applicable index +-- constraint for array aggregates with others choices. +-- +-- TEST DESCRIPTION +-- In this test, we declare several unconstrained array types, and +-- several dynamic subtypes. We then test a variety of cases of using +-- appropriate aggregates. Some cases expect to raise Constraint_Error. +-- +-- HISTORY: +-- 16 DEC 1999 RLB Initial Version. + +with Report; +procedure C433001 is + + type Color_Type is (Red, Orange, Yellow, Green, Blue, Indigo, Violet); + + type Array_1 is array (Positive range <>) of Integer; + + subtype Sub_1_1 is Array_1 (Report.Ident_Int(1) .. Report.Ident_Int(3)); + subtype Sub_1_2 is Array_1 (Report.Ident_Int(3) .. Report.Ident_Int(5)); + subtype Sub_1_3 is Array_1 (Report.Ident_Int(5) .. Report.Ident_Int(9)); + + type Array_2 is array (Color_Type range <>) of Integer; + + subtype Sub_2_1 is Array_2 (Color_Type'Val(Report.Ident_Int(0)) .. + Color_Type'Val(Report.Ident_Int(2))); + -- Red .. Yellow + subtype Sub_2_2 is Array_2 (Color_Type'Val(Report.Ident_Int(3)) .. + Color_Type'Val(Report.Ident_Int(6))); + -- Green .. Violet + type Array_3 is array (Color_Type range <>, Positive range <>) of Integer; + + subtype Sub_3_1 is Array_3 (Color_Type'Val(Report.Ident_Int(0)) .. + Color_Type'Val(Report.Ident_Int(2)), + Report.Ident_Int(3) .. Report.Ident_Int(5)); + -- Red .. Yellow, 3 .. 5 + subtype Sub_3_2 is Array_3 (Color_Type'Val(Report.Ident_Int(1)) .. + Color_Type'Val(Report.Ident_Int(3)), + Report.Ident_Int(6) .. Report.Ident_Int(8)); + -- Orange .. Green, 6 .. 8 + + procedure Check_1 (Obj : Array_1; Low, High : Integer; + First_Component, Second_Component, + Last_Component : Integer; + Test_Case : Character) is + begin + if Obj'First /= Low then + Report.Failed ("Low bound incorrect (" & Test_Case & ")"); + end if; + if Obj'Last /= High then + Report.Failed ("High bound incorrect (" & Test_Case & ")"); + end if; + if Obj(Low) /= First_Component then + Report.Failed ("First Component incorrect (" & Test_Case & ")"); + end if; + if Obj(Low+1) /= Second_Component then + Report.Failed ("First Component incorrect (" & Test_Case & ")"); + end if; + if Obj(High) /= Last_Component then + Report.Failed ("First Component incorrect (" & Test_Case & ")"); + end if; + end Check_1; + + procedure Check_2 (Obj : Array_2; Low, High : Color_Type; + First_Component, Second_Component, + Last_Component : Integer; + Test_Case : Character) is + begin + if Obj'First /= Low then + Report.Failed ("Low bound incorrect (" & Test_Case & ")"); + end if; + if Obj'Last /= High then + Report.Failed ("High bound incorrect (" & Test_Case & ")"); + end if; + if Obj(Low) /= First_Component then + Report.Failed ("First Component incorrect (" & Test_Case & ")"); + end if; + if Obj(Color_Type'Succ(Low)) /= Second_Component then + Report.Failed ("First Component incorrect (" & Test_Case & ")"); + end if; + if Obj(High) /= Last_Component then + Report.Failed ("First Component incorrect (" & Test_Case & ")"); + end if; + end Check_2; + + procedure Check_3 (Test_Obj, Check_Obj : Array_3; + Low_1, High_1 : Color_Type; + Low_2, High_2 : Integer; + Test_Case : Character) is + begin + if Test_Obj'First(1) /= Low_1 then + Report.Failed ("Low bound for dimension 1 incorrect (" & + Test_Case & ")"); + end if; + if Test_Obj'Last(1) /= High_1 then + Report.Failed ("High bound for dimension 1 incorrect (" & + Test_Case & ")"); + end if; + if Test_Obj'First(2) /= Low_2 then + Report.Failed ("Low bound for dimension 2 incorrect (" & + Test_Case & ")"); + end if; + if Test_Obj'Last(2) /= High_2 then + Report.Failed ("High bound for dimension 2 incorrect (" & + Test_Case & ")"); + end if; + if Test_Obj /= Check_Obj then + Report.Failed ("Components incorrect (" & Test_Case & ")"); + end if; + end Check_3; + + procedure Subtest_Check_1 (Obj : Sub_1_3; + First_Component, Second_Component, + Last_Component : Integer; + Test_Case : Character) is + begin + Check_1 (Obj, 5, 9, First_Component, Second_Component, Last_Component, + Test_Case); + end Subtest_Check_1; + + procedure Subtest_Check_2 (Obj : Sub_2_2; + First_Component, Second_Component, + Last_Component : Integer; + Test_Case : Character) is + begin + Check_2 (Obj, Green, Violet, First_Component, Second_Component, + Last_Component, Test_Case); + end Subtest_Check_2; + + procedure Subtest_Check_3 (Obj : Sub_3_2; + Test_Case : Character) is + begin + Check_3 (Obj, Obj, Orange, Green, 6, 8, Test_Case); + end Subtest_Check_3; + +begin + + Report.Test ("C433001", + "Check that an others choice is allowed in an array " & + "aggregate whose applicable index constraint is dynamic. " & + "Also check index choices are within the applicable index " & + "constraint for array aggregates with others choices"); + + -- Check with a qualified expression: + Check_1 (Sub_1_1'(2, 3, others => 4), Low => 1, High => 3, + First_Component => 2, Second_Component => 3, Last_Component => 4, + Test_Case => 'A'); + + Check_2 (Sub_2_1'(1, others => Report.Ident_Int(6)), + Low => Red, High => Yellow, + First_Component => 1, Second_Component => 6, Last_Component => 6, + Test_Case => 'B'); + + Check_3 (Sub_3_1'((1, others => 3), others => (2, 4, others => 6)), + Check_Obj => ((1, 3, 3), (2, 4, 6), (2, 4, 6)), + Low_1 => Red, High_1 => Yellow, Low_2 => 3, High_2 => 5, + Test_Case => 'C'); + + -- Check that the others clause does not need to represent any components: + Check_1 (Sub_1_2'(5, 6, 8, others => 10), Low => 3, High => 5, + First_Component => 5, Second_Component => 6, Last_Component => 8, + Test_Case => 'D'); + + -- Check named choices are allowed: + Check_1 (Sub_1_1'(2 => Report.Ident_Int(-1), others => 8), + Low => 1, High => 3, + First_Component => 8, Second_Component => -1, Last_Component => 8, + Test_Case => 'E'); + + -- Check named choices and formal parameters: + Subtest_Check_1 ((6 => 4, 8 => 86, others => 1), + First_Component => 1, Second_Component => 4, Last_Component => 1, + Test_Case => 'F'); + + Subtest_Check_2 ((Green => Report.Ident_Int(88), Violet => 89, + Indigo => Report.Ident_Int(42), Blue => 0, others => -1), + First_Component => 88, Second_Component => 0, Last_Component => 89, + Test_Case => 'G'); + + Subtest_Check_3 ((Yellow => (7 => 0, others => 10), others => (1, 2, 3)), + Test_Case => 'H'); + + -- Check object declarations and assignment: + declare + Var : Sub_1_2 := (4, 36, others => 86); + begin + Check_1 (Var, Low => 3, High => 5, + First_Component => 4, Second_Component => 36, + Last_Component => 86, + Test_Case => 'I'); + Var := (5 => 415, others => Report.Ident_Int(1522)); + Check_1 (Var, Low => 3, High => 5, + First_Component => 1522, Second_Component => 1522, + Last_Component => 415, + Test_Case => 'J'); + end; + + -- Check positional aggregates that are too long: + begin + Subtest_Check_2 ((Report.Ident_Int(88), 89, 90, 91, 92, others => 93), + First_Component => 88, Second_Component => 89, + Last_Component => 91, + Test_Case => 'K'); + Report.Failed ("Constraint_Error not raised by positional " & + "aggregate with too many choices (K)"); + exception + when Constraint_Error => null; -- Expected exception. + end; + + begin + Subtest_Check_3 (((0, others => 10), (2, 3, others => 4), + (5, 6, 8, others => 10), (1, 4, 7), others => (1, 2, 3)), + Test_Case => 'L'); + Report.Failed ("Constraint_Error not raised by positional " & + "aggregate with too many choices (L)"); + exception + when Constraint_Error => null; -- Expected exception. + end; + + -- Check named aggregates with choices in the index subtype but not in the + -- applicable index constraint: + + begin + Subtest_Check_1 ((5 => Report.Ident_Int(88), 8 => 89, + 10 => 66, -- 10 not in applicable index constraint + others => 93), + First_Component => 88, Second_Component => 93, + Last_Component => 93, + Test_Case => 'M'); + Report.Failed ("Constraint_Error not raised by aggregate choice " & + "index outside of applicable index constraint (M)"); + exception + when Constraint_Error => null; -- Expected exception. + end; + + begin + Subtest_Check_2 ( + (Yellow => 23, -- Yellow not in applicable index constraint. + Blue => 16, others => 77), + First_Component => 77, Second_Component => 16, + Last_Component => 77, + Test_Case => 'N'); + Report.Failed ("Constraint_Error not raised by aggregate choice " & + "index outside of applicable index constraint (N)"); + exception + when Constraint_Error => null; -- Expected exception. + end; + + begin + Subtest_Check_3 ((Orange => (0, others => 10), + Blue => (2, 3, others => 4), -- Blue not in applicable index cons. + others => (1, 2, 3)), + Test_Case => 'P'); + Report.Failed ("Constraint_Error not raised by aggregate choice " & + "index outside of applicable index constraint (P)"); + exception + when Constraint_Error => null; -- Expected exception. + end; + + begin + Subtest_Check_3 ((Orange => (6 => 0, others => Report.Ident_Int(10)), + Green => (8 => 2, 4 => 3, others => 7), + -- 4 not in applicable index cons. + others => (1, 2, 3, others => Report.Ident_Int(10))), + Test_Case => 'Q'); + Report.Failed ("Constraint_Error not raised by aggregate choice " & + "index outside of applicable index constraint (Q)"); + exception + when Constraint_Error => null; -- Expected exception. + end; + + Report.Result; + +end C433001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c44003d.ada b/gcc/testsuite/ada/acats/tests/c4/c44003d.ada new file mode 100644 index 000000000..57ad7c4d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c44003d.ada @@ -0,0 +1,188 @@ +-- C44003D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK FOR CORRECT PRECEDENCE OF PREDEFINED AND OVERLOADED +-- OPERATIONS ON PREDEFINED TYPE FLOAT, USER-DEFINED TYPES, AND +-- ONE-DIMENSIONAL ARRAYS WITH COMPONENTS OF TYPE FLOAT. + +-- HISTORY: +-- RJW 10/13/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C44003D IS + +BEGIN + TEST ("C44003D", "CHECK FOR CORRECT PRECEDENCE OF PREDEFINED " & + "AND OVERLOADED OPERATIONS ON PREDEFINED TYPE " & + "FLOAT, USER-DEFINED TYPES, AND ONE-DIMEN" & + "SIONAL ARRAYS WITH COMPONENTS OF TYPE FLOAT"); + +----- PREDEFINED FLOAT: + + DECLARE + F1 : FLOAT := 1.0; + F2 : FLOAT := 2.0; + F5 : FLOAT := 5.0; + + FUNCTION "OR" (LEFT, RIGHT : FLOAT) RETURN FLOAT IS + BEGIN + RETURN 4.5; + END "OR"; + + FUNCTION "<" (LEFT, RIGHT : FLOAT) RETURN FLOAT IS + BEGIN + RETURN 5.5; + END "<"; + + FUNCTION "-" (LEFT, RIGHT : FLOAT) RETURN FLOAT IS + BEGIN + RETURN 6.5; + END "-"; + + FUNCTION "+" (RIGHT : FLOAT) RETURN FLOAT IS + BEGIN + RETURN 7.5; + END "+"; + + FUNCTION "*" (LEFT, RIGHT : FLOAT) RETURN FLOAT IS + BEGIN + RETURN 8.5; + END "*"; + + FUNCTION "NOT" (RIGHT : FLOAT) RETURN FLOAT IS + BEGIN + RETURN 9.5; + END "NOT"; + + BEGIN + IF NOT (-ABS F1 + F2 / F1 + F5 ** 2 = 26.0 AND + F1 > 0.0 AND + - F2 * F2 ** 3 = -8.5) THEN + FAILED ("INCORRECT RESULT - 1"); + END IF; + + IF (F1 OR NOT F2 < F1 - F5 * F5 ** 3) /= 4.5 THEN + FAILED ("INCORRECT RESULT - 2"); + END IF; + END; + +----- USER-DEFINED TYPE: + + DECLARE + TYPE USR IS DIGITS 5; + + F1 : USR := 1.0; + F2 : USR := 2.0; + F5 : USR := 5.0; + + FUNCTION "AND" (LEFT, RIGHT : USR) RETURN USR IS + BEGIN + RETURN 4.5; + END "AND"; + + FUNCTION ">=" (LEFT, RIGHT : USR) RETURN USR IS + BEGIN + RETURN 5.5; + END ">="; + + FUNCTION "+" (LEFT, RIGHT : USR) RETURN USR IS + BEGIN + RETURN 6.5; + END "+"; + + FUNCTION "-" (RIGHT : USR) RETURN USR IS + BEGIN + RETURN 7.5; + END "-"; + + FUNCTION "/" (LEFT, RIGHT : USR) RETURN USR IS + BEGIN + RETURN 8.5; + END "/"; + + FUNCTION "**" (LEFT, RIGHT : USR) RETURN USR IS + BEGIN + RETURN 9.5; + END "**"; + BEGIN + IF +F5 - F2 * F1 ** 2 /= 3.0 OR + ABS F1 <= 0.0 OR + - F2 * F2 ** 3.0 /= 7.5 THEN + FAILED ("INCORRECT RESULT - 3"); + END IF; + + IF (F1 AND F2 >= F1 + F5 / F5 ** 3) /= 4.5 THEN + FAILED ("INCORRECT RESULT - 4"); + END IF; + END; + +----- ARRAYS: + + DECLARE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF FLOAT; + + SUBTYPE SARR IS ARR (1 .. 3); + + F1 : SARR := (OTHERS => 1.0); + F2 : SARR := (OTHERS => 2.0); + F5 : SARR := (OTHERS => 5.0); + + FUNCTION "XOR" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => 4.5); + END "XOR"; + + FUNCTION "<=" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => 5.5); + END "<="; + + FUNCTION "&" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => 6.5); + END "&"; + + FUNCTION "MOD" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => 8.5); + END "MOD"; + + FUNCTION "ABS" (RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => 9.5); + END "ABS"; + BEGIN + IF (ABS F1 <= F2 & F5 MOD F1 XOR F1) /= (1 .. 3 => 4.5) THEN + FAILED ("INCORRECT RESULT - 5"); + END IF; + + IF (ABS F1 & F2) /= (1 .. 3 => 6.5) OR + (F1 MOD F2 <= F5) /= (1 .. 3 => 5.5) THEN + FAILED ("INCORRECT RESULT - 6"); + END IF; + END; + + RESULT; +END C44003D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c44003f.ada b/gcc/testsuite/ada/acats/tests/c4/c44003f.ada new file mode 100644 index 000000000..11121b20c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c44003f.ada @@ -0,0 +1,143 @@ +-- C44003F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK FOR CORRECT PRECEDENCE OF PRE-DEFINED AND OVERLOADED +-- OPERATIONS ON ENUMERATION TYPES OTHER THAN BOOLEAN OR CHARACTER +-- AND ONE-DIMENSIONAL ARRAYS WITH COMPONENTS OF SUCH TYPES. + +-- HISTORY: +-- RJW 10/13/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C44003F IS + + TYPE ENUM IS (ZERO, ONE, TWO, THREE, FOUR, FIVE); + +BEGIN + TEST ("C44003F", "CHECK FOR CORRECT PRECEDENCE OF PRE-DEFINED " & + "AND OVERLOADED OPERATIONS ON ENUMERATION " & + "TYPES OTHER THAN BOOLEAN OR CHARACTER AND " & + "ONE-DIMENSIONAL ARRAYS WITH COMPONENTS OF " & + "SUCH TYPES"); + + +----- ENUMERATION TYPE: + + DECLARE + E1 : ENUM := ONE; + E2 : ENUM := TWO; + E5 : ENUM := FIVE; + + FUNCTION "AND" (LEFT, RIGHT : ENUM) RETURN ENUM IS + BEGIN + RETURN ZERO; + END "AND"; + + FUNCTION "<" (LEFT, RIGHT : ENUM) RETURN ENUM IS + BEGIN + RETURN THREE; + END "<"; + + FUNCTION "-" (LEFT, RIGHT : ENUM) RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (ENUM'POS (LEFT) - ENUM'POS (RIGHT)); + END "-"; + + FUNCTION "+" (RIGHT : ENUM) RETURN ENUM IS + BEGIN + RETURN RIGHT; + END "+"; + + FUNCTION "*" (LEFT, RIGHT : ENUM) RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (ENUM'POS (LEFT) * ENUM'POS (RIGHT)); + END "*"; + + FUNCTION "**" (LEFT, RIGHT : ENUM) RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (ENUM'POS (LEFT) ** ENUM'POS (RIGHT)); + END "**"; + + BEGIN + IF NOT (+E1 < E2) OR NOT (E2 >= +E2) OR NOT (E5 = +FIVE) THEN + FAILED ("INCORRECT RESULT - 1"); + END IF; + + IF (E5 ** E1 AND E2) /= (E5 - E1 * E5 ** E1) THEN + FAILED ("INCORRECT RESULT - 2"); + END IF; + + END; + +----- ARRAYS: + + DECLARE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF ENUM; + + SUBTYPE SARR IS ARR (1 .. 3); + + E1 : SARR := (OTHERS => ONE); + E2 : SARR := (OTHERS => TWO); + E5 : SARR := (OTHERS => FIVE); + + FUNCTION "XOR" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => ZERO); + END "XOR"; + + FUNCTION "<=" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => THREE); + END "<="; + + FUNCTION "+" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => ZERO); + END "+"; + + FUNCTION "MOD" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => THREE); + END "MOD"; + + FUNCTION "**" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => FOUR); + END "**"; + BEGIN + IF (E5 ** E1 <= E2 + E5 MOD E1 XOR E1) /= (1 .. 3 => ZERO) + THEN + FAILED ("INCORRECT RESULT - 3"); + END IF; + + IF (E5 ** E1 & E2) /= (FOUR, FOUR, FOUR, TWO, TWO, TWO) OR + (E1 MOD E2 <= E5) /= (1 .. 3 => THREE) THEN + FAILED ("INCORRECT RESULT - 4"); + END IF; + END; + + RESULT; + +END C44003F; diff --git a/gcc/testsuite/ada/acats/tests/c4/c44003g.ada b/gcc/testsuite/ada/acats/tests/c4/c44003g.ada new file mode 100644 index 000000000..6825cc218 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c44003g.ada @@ -0,0 +1,134 @@ +-- C44003G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK FOR CORRECT PRECEDENCE OF PRE-DEFINED AND OVERLOADED +-- OPERATIONS ON BOOLEAN TYPES AND ONE-DIMENSIONAL ARRAYS WITH +-- COMPONENTS OF TYPE BOOLEAN. + +-- HISTORY: +-- RJW 10/13/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C44003G IS + +BEGIN + TEST ("C44003G", "CHECK FOR CORRECT PRECEDENCE OF PRE-DEFINED " & + "AND OVERLOADED OPERATIONS ON BOOLEAN TYPES " & + "AND ONE-DIMENSIONAL ARRAYS WITH COMPONENTS OF " & + "TYPE BOOLEAN"); + +----- PREDEFINED BOOLEAN: + + DECLARE + T : BOOLEAN := TRUE; + F : BOOLEAN := FALSE; + + FUNCTION "AND" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END "AND"; + + FUNCTION "<" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END "<"; + + FUNCTION "-" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END "-"; + + FUNCTION "+" (RIGHT : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN NOT RIGHT; + END "+"; + + FUNCTION "*" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END "*"; + + FUNCTION "**" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END "**"; + + BEGIN + IF NOT (+T = F) OR T /= +F OR (TRUE AND FALSE ** TRUE) OR + NOT (+T < F) OR NOT (T - F * T) OR (NOT T - F XOR + F - F) + THEN + FAILED ("INCORRECT RESULT - 1"); + END IF; + + END; + +----- ARRAYS: + + DECLARE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + + SUBTYPE SARR IS ARR (1 .. 3); + + T : SARR := (OTHERS => TRUE); + F : SARR := (OTHERS => FALSE); + + FUNCTION "XOR" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => FALSE); + END "XOR"; + + FUNCTION "<=" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => TRUE); + END "<="; + + FUNCTION "+" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => FALSE); + END "+"; + + FUNCTION "MOD" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => TRUE); + END "MOD"; + + FUNCTION "**" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => FALSE); + END "**"; + BEGIN + IF (F ** T <= F + T MOD T XOR T) /= (1 .. 3 => FALSE) + THEN + FAILED ("INCORRECT RESULT - 2"); + END IF; + + IF F ** T & T /= NOT T & T OR + (T MOD F <= T) /= (1 .. 3 => TRUE) THEN + FAILED ("INCORRECT RESULT - 3"); + END IF; + END; + + RESULT; +END C44003G; diff --git a/gcc/testsuite/ada/acats/tests/c4/c450001.a b/gcc/testsuite/ada/acats/tests/c4/c450001.a new file mode 100644 index 000000000..e398ffc63 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c450001.a @@ -0,0 +1,434 @@ +-- C450001.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 operations on modular types perform correctly. +-- +-- Check that loops over the range of a modular type do not over or +-- under run the loop. +-- +-- TEST DESCRIPTION: +-- Check logical and arithmetic operations. +-- (Attributes are tested elsewhere) +-- Checks to make sure that: +-- for X in Mod_Type loop +-- doesn't do something silly like infinite loop. +-- +-- +-- CHANGE HISTORY: +-- 20 SEP 95 SAIC Initial version +-- 20 FEB 96 SAIC Added underrun cases for 2.1 +-- +--! + +----------------------------------------------------------------- C450001_0 + +package C450001_0 is + + type Unsigned_8_Bit is mod 2**8; + + Shy_By_One : constant := 2**8-1; + + Heavy_By_Two : constant := 2**8+2; + + type Unsigned_Edge_8 is mod Shy_By_One; + + type Unsigned_Over_8 is mod Heavy_By_Two; + + procedure Loop_Check; + + -- embed some calls to Report.Ident_Int: + + function ID( U8B: Unsigned_8_Bit ) return Unsigned_8_Bit; + function ID( UEB: Unsigned_Edge_8 ) return Unsigned_Edge_8; + function ID( UOB: Unsigned_Over_8 ) return Unsigned_Over_8; + +end C450001_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body C450001_0 is + + procedure Loop_Check is + Counter_Check : Natural := 0; + begin + for Ever in Unsigned_8_Bit loop + Counter_Check := Report.Ident_Int(Counter_Check) + 1; + if Counter_Check > 2**8 then + Report.Failed("Unsigned_8_Bit loop overrun"); + exit; + end if; + end loop; + + if Counter_Check < 2**8 then + Report.Failed("Unsigned_8_Bit loop underrun"); + end if; + + Counter_Check := 0; + + for Never in Unsigned_Edge_8 loop + Counter_Check := Report.Ident_Int(Counter_Check) + 1; + if Counter_Check > Shy_By_One then + Report.Failed("Unsigned_Edge_8 loop overrun"); + exit; + end if; + end loop; + + if Counter_Check < Shy_By_One then + Report.Failed("Unsigned_Edge_8 loop underrun"); + end if; + + Counter_Check := 0; + + for Getful in reverse Unsigned_Over_8 loop + Counter_Check := Report.Ident_Int(Counter_Check) + 1; + if Counter_Check > Heavy_By_Two then + Report.Failed("Unsigned_Over_8 loop overrun"); + exit; + end if; + end loop; + + if Counter_Check < Heavy_By_Two then + Report.Failed("Unsigned_Over_8 loop underrun"); + end if; + + end Loop_Check; + + function ID( U8B: Unsigned_8_Bit ) return Unsigned_8_Bit is + begin + return Unsigned_8_Bit(Report.Ident_Int(Integer(U8B))); + end ID; + + function ID( UEB: Unsigned_Edge_8 ) return Unsigned_Edge_8 is + begin + return Unsigned_Edge_8(Report.Ident_Int(Integer(UEB))); + end ID; + + function ID( UOB: Unsigned_Over_8 ) return Unsigned_Over_8 is + begin + return Unsigned_Over_8(Report.Ident_Int(Integer(UOB))); + end ID; + +end C450001_0; + +------------------------------------------------------------------- C450001 + +with Report; +with C450001_0; +with TCTouch; +procedure C450001 is + use C450001_0; + + BR : constant String := " produced the wrong result"; + + procedure Is_T(B:Boolean;S:String) renames TCTouch.Assert; + procedure Is_F(B:Boolean;S:String) renames TCTouch.Assert_Not; + + Whole_8_A, Whole_8_B, Whole_8_C : C450001_0.Unsigned_8_Bit; + + Short_8_A, Short_8_B, Short_8_C : C450001_0.Unsigned_Edge_8; + + Over_8_A, Over_8_B, Over_8_C : C450001_0.Unsigned_Over_8; + +begin -- Main test procedure. C450001 + + Report.Test ("C450001", "Check that operations on modular types " & + "perform correctly." ); + + + -- the cases for the whole 8 bit type are pretty simple + + Whole_8_A := 2#00000000#; + Whole_8_B := 2#11111111#; + + Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#00000000#,"8 bit and" & BR); + Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111111#,"8 bit or" & BR); + Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#11111111#,"8 bit xor" & BR); + + Whole_8_A := 2#00001111#; + Whole_8_B := 2#11111111#; + + Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#00001111#,"8 bit and" & BR); + Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111111#,"8 bit or" & BR); + Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#11110000#,"8 bit xor" & BR); + + Whole_8_A := 2#10101010#; + Whole_8_B := 2#11110000#; + + Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#10100000#,"8 bit and" & BR); + Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111010#,"8 bit or" & BR); + Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#01011010#,"8 bit xor" & BR); + + -- the cases for the partial 8 bit type involve subtracting the modulus + -- from results that exceed the modulus. + -- hence, any of the following operations that exceed 2#11111110# must + -- have 2#11111111# subtracted from the result; i.e. where you would + -- expect to see 2#11111111# as in the above operations, the correct + -- result will be 2#00000000#. Note that 2#11111111# is not a legal + -- value of type C450001_0.Unsigned_Edge_8. + + Short_8_A := 2#11100101#; + Short_8_B := 2#00011111#; + + Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#00000101#,"8 short and 1" & BR); + Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#00000000#,"8 short or 1" & BR); + Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#11111010#,"8 short xor 1" & BR); + + Short_8_A := 2#11110000#; + Short_8_B := 2#11111110#; + + Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#11110000#,"8 short and 2" & BR); + Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#11111110#,"8 short or 2" & BR); + Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#00001110#,"8 short xor 2" & BR); + + Short_8_A := 2#10101010#; + Short_8_B := 2#01010101#; + + Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#00000000#,"8 short and 3" & BR); + Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#00000000#,"8 short or 3" & BR); + Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#00000000#,"8 short xor 3" & BR); + + Short_8_A := 2#10101010#; + Short_8_B := 2#11111110#; + + Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#10101010#,"8 short and 4" & BR); + Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#11111110#,"8 short or 4" & BR); + Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#01010100#,"8 short xor 4" & BR); + + -- the cases for the over 8 bit type have similar issues to the short type + -- however the bit patterns are a little different. The rule is to subtract + -- the modulus (258) from any resulting value equal or greater than the + -- modulus -- note that 258 = 2#100000010# + + Over_8_A := 2#100000000#; + Over_8_B := 2#011111111#; + + Is_T((ID(Over_8_A) and ID(Over_8_B)) = 2#000000000#,"8 over and" & BR); + Is_T((ID(Over_8_A) or ID(Over_8_B)) = 2#011111101#,"8 over or" & BR); + Is_T((ID(Over_8_A) xor ID(Over_8_B)) = 2#011111101#,"8 over xor" & BR); + + Over_8_A := 2#100000001#; + Over_8_B := 2#011111111#; + + Is_T((ID(Over_8_A) and ID(Over_8_B)) = 2#000000001#,"8 over and" & BR); + Is_T((ID(Over_8_A) or ID(Over_8_B)) = 2#011111101#,"8 over or" & BR); + Is_T((ID(Over_8_A) xor ID(Over_8_B)) = 2#011111100#,"8 over xor" & BR); + + + + Whole_8_A := 128; + Whole_8_B := 255; + + Is_T(ID(Whole_8_A) /= ID(Whole_8_B), "8 /=" & BR); + Is_F(ID(Whole_8_A) = ID(Whole_8_B), "8 =" & BR); + + Is_T(ID(Whole_8_A) <= ID(Whole_8_B), "8 <=" & BR); + Is_T(ID(Whole_8_A) < ID(Whole_8_B), "8 < " & BR); + + Is_F(ID(Whole_8_A) >= ID(Whole_8_B), "8 >=" & BR); + Is_T(ID(Whole_8_A) > ID(Whole_8_B + 7), "8 > " & BR); + + Is_T(ID(Whole_8_A) in ID(100)..ID(200), "8 in" & BR); + Is_F(ID(Whole_8_A) not in ID(100)..ID(200), "8 not in" & BR); + + Is_F(ID(Whole_8_A) in ID(200)..ID(250), "8 in" & BR); + Is_T(ID(Whole_8_A) not in ID(200)..ID(250), "8 not in" & BR); + + Short_8_A := 127; + Short_8_B := 254; + + Is_T(ID(Short_8_A) /= ID(Short_8_B), "short 8 /=" & BR); + Is_F(ID(Short_8_A) = ID(Short_8_B), "short 8 =" & BR); + + Is_T(ID(Short_8_A) <= ID(Short_8_B), "short 8 <=" & BR); + Is_T(ID(Short_8_A) < ID(Short_8_B), "short 8 < " & BR); + + Is_F(ID(Short_8_A) >= ID(Short_8_B), "short 8 >=" & BR); + Is_F(ID(Short_8_A) > ID(Short_8_B), "short 8 > " & BR); + + Is_T(ID(Short_8_A) in ID(100)..ID(200), "8 in" & BR); + Is_F(ID(Short_8_A) not in ID(100)..ID(200), "8 not in" & BR); + + Is_F(ID(Short_8_A) in ID(200)..ID(250), "8 in" & BR); + Is_T(ID(Short_8_A) not in ID(200)..ID(250), "8 not in" & BR); + + + Whole_8_A := 1; + Whole_8_B := 254; + Short_8_A := 1; + Short_8_B := 2; + + Whole_8_C := ID(Whole_8_A) + ID(Whole_8_B); + Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 binary + 1" & BR); + + Whole_8_C := Whole_8_C + ID(Whole_8_A); + Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'First, "8 binary + 2" & BR); + + Whole_8_C := ID(Whole_8_A) - ID(Whole_8_A); + Is_T(Whole_8_C = 0, "8 binary -" & BR); + + Whole_8_C := Whole_8_C - ID(Whole_8_A); + Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 binary + 3" & BR); + + Short_8_C := ID(Short_8_A) + ID(C450001_0.Unsigned_Edge_8'Last); + Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'First, "Short binary + 1" & BR); + + Short_8_C := Short_8_A + ID(Short_8_A); + Is_T(Short_8_C = ID(Short_8_B), "Short binary + 2" & BR); + + Short_8_C := ID(Short_8_A) - ID(Short_8_A); + Is_T(Short_8_C = 0, "Short 8 binary -" & BR); + + Short_8_C := Short_8_C - ID(Short_8_A); + Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'Last, "Short binary + 3" & BR); + + + Whole_8_C := ( + ID(Whole_8_B) ); + Is_T(Whole_8_C = 254, "8 unary +" & BR); + + Whole_8_C := ( - ID(Whole_8_A) ); + Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 unary -" & BR); + + Whole_8_C := ( - ID(0) ); + Is_T(Whole_8_C = 0, "8 unary -0" & BR); + + Short_8_C := ( + ID(C450001_0.Unsigned_Edge_8'Last) ); + Is_T(Short_8_C = 254, "Short 8 unary +" & BR); + + Short_8_C := ( - ID(Short_8_A) ); + Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'Last, "Short 8 unary -" & BR); + + + Whole_8_A := 20; + Whole_8_B := 255; + + Whole_8_C := ID(Whole_8_A) * ID(Whole_8_B); -- 5100 = 19*256 + 236 (256-20) + Is_T(Whole_8_C = 236, "8 *" & BR); + + Short_8_A := 9; + Short_8_B := 254; + + Short_8_C := ID(Short_8_A) * ID(Short_8_B); -- 2286 = 8*255 + 246 (255-9) + Is_T(Short_8_C = 246, "short 8 *" & BR); + + Over_8_A := 12; + Over_8_B := 86; + + Over_8_C := ID(Over_8_A) * ID(Over_8_B); -- 1032 = 4*258 + 0 + Is_T(Over_8_C = 0, "over 8 *" & BR); + + + Whole_8_A := 255; + Whole_8_B := 4; + + Whole_8_C := ID(Whole_8_A) / ID(Whole_8_B); + Is_T(Whole_8_C = 63, "8 /" & BR); + + Short_8_A := 253; + Short_8_B := 127; + + Short_8_C := ID(Short_8_A) / ID(Short_8_B); + Is_T(Short_8_C = 1, "short 8 / 1" & BR); + + Short_8_C := ID(Short_8_A) / ID(126); + Is_T(Short_8_C = 2, "short 8 / 2" & BR); + + + Whole_8_A := 255; + Whole_8_B := 254; + + Whole_8_C := ID(Whole_8_A) rem ID(Whole_8_B); + Is_T(Whole_8_C = 1, "8 rem" & BR); + + Short_8_A := 222; + Short_8_B := 111; + + Short_8_C := ID(Short_8_A) rem ID(Short_8_B); + Is_T(Short_8_C = 0, "short 8 rem" & BR); + + + Whole_8_A := 99; + Whole_8_B := 9; + + Whole_8_C := ID(Whole_8_A) mod ID(Whole_8_B); + Is_T(Whole_8_C = 0, "8 mod" & BR); + + Short_8_A := 254; + Short_8_B := 250; + + Short_8_C := ID(Short_8_A) mod ID(Short_8_B); + Is_T(Short_8_C = 4, "short 8 mod" & BR); + + + Whole_8_A := 99; + + Whole_8_C := abs Whole_8_A; + Is_T(Whole_8_C = ID(99), "8 abs" & BR); + + Short_8_A := 254; + + Short_8_C := ID( abs Short_8_A ); + Is_T(Short_8_C = 254, "short 8 abs" & BR); + + + Whole_8_B := 2#00001111#; + + Whole_8_C := not Whole_8_B; + Is_T(Whole_8_C = ID(2#11110000#), "8 not" & BR); + + Short_8_B := 2#00001111#; -- 15 + + Short_8_C := ID( not Short_8_B ); -- 254 - 15 + Is_T(Short_8_C = 2#11101111#, "short 8 not" & BR); -- 239 + + + Whole_8_A := 2; + + Whole_8_C := Whole_8_A ** 7; + Is_T(Whole_8_C = ID(128), "2 ** 7, whole 8" & BR); + + Whole_8_C := Whole_8_A ** 9; + Is_T(Whole_8_C = ID(0), "2 ** 9, whole 8" & BR); + + Short_8_A := 4; + + Short_8_C := ID( Short_8_A ) ** 4; + Is_T(Short_8_C = 1, "4 ** 4, short" & BR); + + Over_8_A := 4; + + Over_8_C := ID( Over_8_A ) ** 4; + Is_T(Over_8_C = 256, "4 ** 4, over" & BR); + + Over_8_C := ID( Over_8_A ) ** 5; -- 1024 = 3*258 + 250 + Is_T(Over_8_C = 250, "4 ** 5, over" & BR); + + + C450001_0.Loop_Check; + + Report.Result; + +end C450001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45112a.ada b/gcc/testsuite/ada/acats/tests/c4/c45112a.ada new file mode 100644 index 000000000..f18b1be57 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45112a.ada @@ -0,0 +1,233 @@ +-- C45112A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF THE RESULT OF A LOGICAL ARRAY OPERATION +-- ARE THE BOUNDS OF THE LEFT OPERAND. + +-- RJW 2/3/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C45112A IS + + TYPE ARR IS ARRAY(INTEGER RANGE <>) OF BOOLEAN; + A1 : ARR(IDENT_INT(3) .. IDENT_INT(4)) := (TRUE, FALSE); + A2 : ARR(IDENT_INT(1) .. IDENT_INT(2)) := (TRUE, FALSE); + SUBTYPE CARR IS ARR (IDENT_INT (A1'FIRST) .. IDENT_INT (A1'LAST)); + + PROCEDURE CHECK (X : ARR; N1, N2 : STRING) IS + BEGIN + IF X'FIRST /= A1'FIRST OR X'LAST /= A1'LAST THEN + FAILED ( "WRONG BOUNDS FOR " & N1 & " FOR " & N2 ); + END IF; + END CHECK; + +BEGIN + + TEST ( "C45112A", "CHECK THE BOUNDS OF THE RESULT OF LOGICAL " & + "ARRAY OPERATIONS" ); + + BEGIN + DECLARE + AAND : CONSTANT ARR := A1 AND A2; + AOR : CONSTANT ARR := A1 OR A2; + AXOR : CONSTANT ARR := A1 XOR A2; + BEGIN + CHECK (AAND, "INITIALIZATION OF CONSTANT ARRAY ", + "'AND'" ); + + CHECK (AOR, "INITIALIZATION OF CONSTANT ARRAY ", + "'OR'" ); + + CHECK (AXOR, "INITIALIZATION OF CONSTANT ARRAY ", + "'XOR'" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED DURING " & + "INTIALIZATIONS" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED DURING " & + "INITIALIZATIONS" ); + END; + + DECLARE + PROCEDURE PROC (A : ARR; STR : STRING) IS + BEGIN + CHECK (A, "FORMAL PARAMETER FOR CONSTRAINED ARRAY", + STR); + END PROC; + BEGIN + PROC ((A1 AND A2), "'AND'" ); + PROC ((A1 OR A2), "'OR'" ); + PROC ((A1 XOR A2), "'XOR'" ); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING TEST FOR FORMAL " & + "PARAMETERS" ); + END; + + DECLARE + FUNCTION FUNCAND RETURN ARR IS + BEGIN + RETURN A1 AND A2; + END FUNCAND; + + FUNCTION FUNCOR RETURN ARR IS + BEGIN + RETURN A1 OR A2; + END FUNCOR; + + FUNCTION FUNCXOR RETURN ARR IS + BEGIN + RETURN A1 XOR A2; + END FUNCXOR; + + BEGIN + CHECK (FUNCAND, "RETURN STATEMENT", "'AND'"); + CHECK (FUNCOR, "RETURN STATEMENT", "'OR'"); + CHECK (FUNCXOR, "RETURN STATEMENT", "'XOR'"); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING TEST FOR RETURN " & + "FROM FUNCTION" ); + END; + + BEGIN + DECLARE + GENERIC + X : IN ARR; + PACKAGE PKG IS + FUNCTION G RETURN ARR; + END PKG; + + PACKAGE BODY PKG IS + FUNCTION G RETURN ARR IS + BEGIN + RETURN X; + END G; + END PKG; + + PACKAGE PAND IS NEW PKG(X => A1 AND A2); + PACKAGE POR IS NEW PKG(X => A1 OR A2); + PACKAGE PXOR IS NEW PKG(X => A1 XOR A2); + BEGIN + CHECK (PAND.G, "GENERIC FORMAL PARAMETER", "'AND'"); + CHECK (POR.G, "GENERIC FORMAL PARAMETER", "'OR'"); + CHECK (PXOR.G, "GENERIC FORMAL PARAMMETER", "'XOR'"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING GENERIC " & + "INSTANTIATION" ); + END; + + DECLARE + TYPE ACC IS ACCESS ARR; + AC : ACC; + + BEGIN + AC := NEW ARR'(A1 AND A2); + CHECK (AC.ALL, "ALLOCATION", "'AND'"); + AC := NEW ARR'(A1 OR A2); + CHECK (AC.ALL, "ALLOCATION", "'OR'"); + AC := NEW ARR'(A1 XOR A2); + CHECK (AC.ALL, "ALLOCATION", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON ALLOCATION" ); + END; + + BEGIN + CHECK (CARR' (A1 AND A2), "QUALIFIED EXPRESSION", "'AND'"); + CHECK (CARR' (A1 OR A2), "QUALIFIED EXPRESSION", "'OR'"); + CHECK (CARR' (A1 XOR A2), "QUALIFIED EXPRESSION", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON QUALIFIED EXPRESSION" ); + END; + + DECLARE + TYPE REC IS + RECORD + RCA : CARR; + END RECORD; + R1 : REC; + + BEGIN + R1 := (RCA => (A1 AND A2)); + CHECK (R1.RCA, "AGGREGATE", "'AND'"); + R1 := (RCA => (A1 OR A2)); + CHECK (R1.RCA, "AGGREGATE", "'OR'"); + R1 := (RCA => (A1 XOR A2)); + CHECK (R1.RCA, "AGGREGATE", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON AGGREGATE" ); + END; + + BEGIN + DECLARE + TYPE RECDEF IS + RECORD + RCDF1 : CARR := A1 AND A2; + RCDF2 : CARR := A1 OR A2; + RCDF3 : CARR := A1 XOR A2; + END RECORD; + RD : RECDEF; + BEGIN + CHECK (RD.RCDF1, "DEFAULT RECORD", "'AND'"); + CHECK (RD.RCDF2, "DEFAULT RECORD", "'OR'"); + CHECK (RD.RCDF3, "DEFAULT RECORD", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON DEFAULT RECORD" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING INITIALIZATION OF " & + "DEFAULT RECORD" ); + END; + + DECLARE + PROCEDURE PDEF (X : CARR := A1 AND A2; + Y : CARR := A1 OR A2; + Z : CARR := A1 XOR A2 ) IS + BEGIN + CHECK (X, "DEFAULT PARAMETER", "'AND'"); + CHECK (Y, "DEFAULT PARAMETER", "'OR'"); + CHECK (Z, "DEFAULT PARAMETER", "'XOR'"); + END PDEF; + + BEGIN + PDEF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON DEFAULT PARM" ); + END; + + RESULT; + +END C45112A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45112b.ada b/gcc/testsuite/ada/acats/tests/c4/c45112b.ada new file mode 100644 index 000000000..ef6a7c0a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45112b.ada @@ -0,0 +1,234 @@ +-- C45112B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE BOUNDS OF THE RESULT OF A LOGICAL ARRAY OPERATION +-- ARE THE BOUNDS OF THE LEFT OPERAND WHEN THE OPERANDS ARE NULL +-- ARRAYS. + +-- RJW 2/3/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C45112B IS + + TYPE ARR IS ARRAY(INTEGER RANGE <>) OF BOOLEAN; + A1 : ARR(IDENT_INT(4) .. IDENT_INT(3)); + A2 : ARR(IDENT_INT(2) .. IDENT_INT(1)); + SUBTYPE CARR IS ARR (IDENT_INT (A1'FIRST) .. IDENT_INT (A1'LAST)); + + PROCEDURE CHECK (X : ARR; N1, N2 : STRING) IS + BEGIN + IF X'FIRST /= A1'FIRST OR X'LAST /= A1'LAST THEN + FAILED ( "WRONG BOUNDS FOR " & N1 & " FOR " & N2 ); + END IF; + END CHECK; + +BEGIN + + TEST ( "C45112B", "CHECK THE BOUNDS OF THE RESULT OF LOGICAL " & + "ARRAY OPERATIONS ON NULL ARRAYS" ); + + BEGIN + DECLARE + AAND : CONSTANT ARR := A1 AND A2; + AOR : CONSTANT ARR := A1 OR A2; + AXOR : CONSTANT ARR := A1 XOR A2; + BEGIN + CHECK (AAND, "INITIALIZATION OF CONSTANT ARRAY ", + "'AND'" ); + + CHECK (AOR, "INITIALIZATION OF CONSTANT ARRAY ", + "'OR'" ); + + CHECK (AXOR, "INITIALIZATION OF CONSTANT ARRAY ", + "'XOR'" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED DURING " & + "INTIALIZATIONS" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED DURING " & + "INITIALIZATIONS" ); + END; + + DECLARE + PROCEDURE PROC (A : ARR; STR : STRING) IS + BEGIN + CHECK (A, "FORMAL PARAMETER FOR CONSTRAINED ARRAY", + STR); + END PROC; + BEGIN + PROC ((A1 AND A2), "'AND'" ); + PROC ((A1 OR A2), "'OR'" ); + PROC ((A1 XOR A2), "'XOR'" ); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING TEST FOR FORMAL " & + "PARAMETERS" ); + END; + + DECLARE + FUNCTION FUNCAND RETURN ARR IS + BEGIN + RETURN A1 AND A2; + END FUNCAND; + + FUNCTION FUNCOR RETURN ARR IS + BEGIN + RETURN A1 OR A2; + END FUNCOR; + + FUNCTION FUNCXOR RETURN ARR IS + BEGIN + RETURN A1 XOR A2; + END FUNCXOR; + + BEGIN + CHECK (FUNCAND, "RETURN STATEMENT", "'AND'"); + CHECK (FUNCOR, "RETURN STATEMENT", "'OR'"); + CHECK (FUNCXOR, "RETURN STATEMENT", "'XOR'"); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING TEST FOR RETURN " & + "FROM FUNCTION" ); + END; + + BEGIN + DECLARE + GENERIC + X : IN ARR; + PACKAGE PKG IS + FUNCTION G RETURN ARR; + END PKG; + + PACKAGE BODY PKG IS + FUNCTION G RETURN ARR IS + BEGIN + RETURN X; + END G; + END PKG; + + PACKAGE PAND IS NEW PKG(X => A1 AND A2); + PACKAGE POR IS NEW PKG(X => A1 OR A2); + PACKAGE PXOR IS NEW PKG(X => A1 XOR A2); + BEGIN + CHECK (PAND.G, "GENERIC FORMAL PARAMETER", "'AND'"); + CHECK (POR.G, "GENERIC FORMAL PARAMETER", "'OR'"); + CHECK (PXOR.G, "GENERIC FORMAL PARAMMETER", "'XOR'"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING GENERIC " & + "INSTANTIATION" ); + END; + + DECLARE + TYPE ACC IS ACCESS ARR; + AC : ACC; + + BEGIN + AC := NEW ARR'(A1 AND A2); + CHECK (AC.ALL, "ALLOCATION", "'AND'"); + AC := NEW ARR'(A1 OR A2); + CHECK (AC.ALL, "ALLOCATION", "'OR'"); + AC := NEW ARR'(A1 XOR A2); + CHECK (AC.ALL, "ALLOCATION", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON ALLOCATION" ); + END; + + BEGIN + CHECK (CARR' (A1 AND A2), "QUALIFIED EXPRESSION", "'AND'"); + CHECK (CARR' (A1 OR A2), "QUALIFIED EXPRESSION", "'OR'"); + CHECK (CARR' (A1 XOR A2), "QUALIFIED EXPRESSION", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON QUALIFIED EXPRESSION" ); + END; + + DECLARE + TYPE REC IS + RECORD + RCA : CARR; + END RECORD; + R1 : REC; + + BEGIN + R1 := (RCA => (A1 AND A2)); + CHECK (R1.RCA, "AGGREGATE", "'AND'"); + R1 := (RCA => (A1 OR A2)); + CHECK (R1.RCA, "AGGREGATE", "'OR'"); + R1 := (RCA => (A1 XOR A2)); + CHECK (R1.RCA, "AGGREGATE", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON AGGREGATE" ); + END; + + BEGIN + DECLARE + TYPE RECDEF IS + RECORD + RCDF1 : CARR := A1 AND A2; + RCDF2 : CARR := A1 OR A2; + RCDF3 : CARR := A1 XOR A2; + END RECORD; + RD : RECDEF; + BEGIN + CHECK (RD.RCDF1, "DEFAULT RECORD", "'AND'"); + CHECK (RD.RCDF2, "DEFAULT RECORD", "'OR'"); + CHECK (RD.RCDF3, "DEFAULT RECORD", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON DEFAULT RECORD" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING INITIALIZATION OF " & + "DEFAULT RECORD" ); + END; + + DECLARE + PROCEDURE PDEF (X : CARR := A1 AND A2; + Y : CARR := A1 OR A2; + Z : CARR := A1 XOR A2 ) IS + BEGIN + CHECK (X, "DEFAULT PARAMETER", "'AND'"); + CHECK (Y, "DEFAULT PARAMETER", "'OR'"); + CHECK (Z, "DEFAULT PARAMETER", "'XOR'"); + END PDEF; + + BEGIN + PDEF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON DEFAULT PARM" ); + END; + + RESULT; + +END C45112B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45113a.ada b/gcc/testsuite/ada/acats/tests/c4/c45113a.ada new file mode 100644 index 000000000..14471d348 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45113a.ada @@ -0,0 +1,91 @@ +-- C45113A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE OPERANDS OF LOGICAL +-- OPERATORS HAVE DIFFERENT LENGTHS. + +-- RJW 1/15/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C45113A IS + +BEGIN + + TEST( "C45113A" , "CHECK ON LOGICAL OPERATORS WITH " & + "OPERANDS OF DIFFERENT LENGTHS" ); + + DECLARE + + TYPE ARR IS ARRAY ( INTEGER RANGE <> ) OF BOOLEAN; + + A : ARR( IDENT_INT(1) .. IDENT_INT(2) ) := ( TRUE, FALSE ); + B : ARR( IDENT_INT(1) .. IDENT_INT(3) ) := ( TRUE, FALSE, + TRUE ); + + BEGIN + + BEGIN -- TEST FOR 'AND'. + IF (A AND B) = B THEN + FAILED ( "A AND B = B" ); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR 'AND'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'AND'" ); + END; + + + BEGIN -- TEST FOR 'OR'. + IF (A OR B) = B THEN + FAILED ( "A OR B = B" ); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR 'OR'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'OR'" ); + END; + + + BEGIN -- TEST FOR 'XOR'. + IF (A XOR B) = B THEN + FAILED ( "A XOR B = B" ); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR 'XOR'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'XOR'" ); + END; + + END; + + RESULT; + +END C45113A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45114b.ada b/gcc/testsuite/ada/acats/tests/c4/c45114b.ada new file mode 100644 index 000000000..d49b9eda5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45114b.ada @@ -0,0 +1,73 @@ +-- C45114B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT LOGICAL OPERATORS ARE DEFINED FOR PACKED BOOLEAN ARRAYS. + +-- RJW 1/17/86 + +WITH REPORT; USE REPORT; +PROCEDURE C45114B IS + +BEGIN + + TEST( "C45114B" , "CHECK THAT LOGICAL OPERATORS ARE DEFINED " & + "FOR PACKED BOOLEAN ARRAYS" ); + + DECLARE + + TYPE ARR IS ARRAY (1 .. 32) OF BOOLEAN; + + PRAGMA PACK (ARR); + + A : ARR := ( TRUE, TRUE, FALSE, FALSE, OTHERS => TRUE ); + B : ARR := ( TRUE, FALSE, TRUE, FALSE, OTHERS => FALSE ); + + A_AND_B : ARR := ( TRUE, OTHERS => FALSE ); + A_OR_B : ARR := ARR'( 4 => FALSE, OTHERS => TRUE ); + A_XOR_B : ARR := ARR'( 1|4 => FALSE, OTHERS => TRUE ); + NOT_A : ARR := ARR'( 3|4 => TRUE, OTHERS => FALSE ); + + BEGIN + + IF ( A AND B ) /= A_AND_B THEN + FAILED ( "'AND' NOT CORRECTLY DEFINED" ); + END IF; + + IF ( A OR B ) /= A_OR_B THEN + FAILED ( "'OR' NOT CORRECTLY DEFINED" ); + END IF; + + IF ( A XOR B ) /= A_XOR_B THEN + FAILED ( "'XOR' NOT CORRECTLY DEFINED" ); + END IF; + + IF NOT A /= NOT_A THEN + FAILED ( "'NOT' NOT CORRECTLY DEFINED" ); + END IF; + + END; + + RESULT; + +END C45114B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c452001.a b/gcc/testsuite/ada/acats/tests/c4/c452001.a new file mode 100644 index 000000000..ec78cd2a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c452001.a @@ -0,0 +1,707 @@ +-- C452001.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: +-- For a type extension, check that predefined equality is defined in +-- terms of the primitive equals operator of the parent type and any +-- tagged components of the extension part. +-- +-- For other composite types, check that the primitive equality operator +-- of any matching tagged components is used to determine equality of the +-- enclosing type. +-- +-- For private types, check that predefined equality is defined in +-- terms of the user-defined (primitive) operator of the full type if +-- the full type is tagged. The partial view of the type may be +-- tagged or untagged. Check that predefined equality for a private +-- type whose full view is untagged is defined in terms of the +-- predefined equality operator of its full type. +-- +-- TEST DESCRIPTION: +-- Tagged types are declared and used as components in several +-- differing composite type declarations, both tagged and untagged. +-- To differentiate between predefined and primitive equality +-- operations, user-defined equality operators are declared for +-- each component type that is to contribute to the equality +-- operator of the composite type that houses it. All user-defined +-- equality operations are designed to yield the opposite result +-- from the predefined operator, given the same component values. +-- +-- For cases where primitive equality is to be incorporated into +-- equality for the enclosing composite type, values are assigned +-- to the component type so that user-defined equality will return +-- True. If predefined equality is to be used instead, then the +-- same strategy results in the equality operator returning False. +-- +-- When equality for a type incorporates the user-defined equality +-- operator of one of its component types, the resulting operator +-- is considered to be the predefined operator of the composite type. +-- This case is confirmed by defining an tagged component of an +-- untagged composite type, then using the resulting untagged type +-- as a component of another composite type. The user-defined operator +-- for the lowest level should still be called. +-- +-- Three cases are set up to test private types: +-- +-- Case 1 Case 2 Case 3 +-- partial view: tagged untagged untagged +-- full view: tagged tagged untagged +-- +-- Types are declared for each of the above cases and user-defined +-- (primitive) operators are declared following the full type +-- declaration of each type (i.e., in the private part). +-- +-- Values are assigned into objects of these types using the same +-- strategy outlined above. Cases 1 and 2 should execute the +-- user-defined operator. Case 3 should ignore the user-defined +-- operator and user predefined equality for the type. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Removed RM references from objective text. +-- 15 Nov 95 SAIC Fixed for 2.0.1 +-- 04 NOV 96 SAIC Typographical revision +-- +--! + +package c452001_0 is + + type Point is + record + X : Integer := 0; + Y : Integer := 0; + end record; + + type Circle is tagged + record + Center : Point; + Radius : Integer; + end record; + + function "=" (L, R : Circle) return Boolean; + + type Colors is (Red, Orange, Yellow, Green, Blue, Purple, Black, White); + + type Colored_Circle is new Circle + with record + Color : Colors := White; + end record; + + function "=" (L, R : Colored_Circle) return Boolean; + -- Override predefined equality for this tagged type. Predefined + -- equality should incorporate user-defined (primitive) equality + -- from type Circle. See C340001 for a test of that feature. + + -- Equality is overridden to ensure that predefined equality + -- incorporates this user-defined function for + -- any composite type with Colored_Circle as a component type. + -- (i.e., the type extension is recognized as a tagged type for + -- the purpose of defining predefined equality for the composite type). + +end C452001_0; + +package body c452001_0 is + + function "=" (L, R : Circle) return Boolean is + begin + return L.Radius = R.Radius; -- circles are same size + end "="; + + function "=" (L, R : Colored_Circle) return Boolean is + begin + return Circle(L) = Circle(R); + end "="; + +end C452001_0; + +with C452001_0; +package C452001_1 is + + type Planet is tagged record + Name : String (1..15); + Representation : C452001_0.Colored_Circle; + end record; + + -- Type Planet will be used to check that predefined equality + -- for a tagged type with a tagged component incorporates + -- user-defined equality for the component type. + + type TC_Planet is new Planet with null record; + + -- A "copy" of Planet. Used to create a type extension. An "=" + -- operator will be defined for this type that should be + -- incorporated by the type extension. + + function "=" (Arg1, Arg2 : in TC_Planet) return Boolean; + + type Craters is array (1..3) of C452001_0.Colored_Circle; + + -- An array type (untagged) with tagged components + + type Moon is new TC_Planet + with record + Crater : Craters; + end record; + + -- A tagged record type. Extended component type is untagged, + -- but its predefined equality operator should incorporate + -- the user-defined operator of its tagged component type. + +end C452001_1; + +package body C452001_1 is + + function "=" (Arg1, Arg2 : in TC_Planet) return Boolean is + begin + return Arg1.Name = Arg2.Name; + end "="; + +end C452001_1; + +package C452001_2 is + + -- Untagged record types + -- Equality should not be incorporated + + type Spacecraft_Design is (Mariner, Pioneer, Viking, Voyager); + type Spacecraft is record + Design : Spacecraft_Design; + Operational : Boolean; + end record; + + function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean; + + type Mission is record + Craft : Spacecraft; + Launch_Date : Natural; + end record; + + type Inventory is array (Positive range <>) of Spacecraft; + +end C452001_2; + +package body C452001_2 is + + function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean is + begin + return L.Design = R.Design; + end "="; + +end C452001_2; + +package C452001_3 is + + type Tagged_Partial_Tagged_Full is tagged private; + procedure Change (Object : in out Tagged_Partial_Tagged_Full; + Value : in Boolean); + + type Untagged_Partial_Tagged_Full is private; + procedure Change (Object : in out Untagged_Partial_Tagged_Full; + Value : in Integer); + + type Untagged_Partial_Untagged_Full is private; + procedure Change (Object : in out Untagged_Partial_Untagged_Full; + Value : in Duration); + +private + + type Tagged_Partial_Tagged_Full is + tagged record + B : Boolean := True; + C : Character := ' '; + end record; + -- predefined equality checks that all components are equal + + function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean; + -- primitive equality checks that records equate in component C only + + type Untagged_Partial_Tagged_Full is + tagged record + I : Integer := 0; + P : Positive := 1; + end record; + -- predefined equality checks that all components are equal + + function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean; + -- primitive equality checks that records equate in component P only + + type Untagged_Partial_Untagged_Full is + record + D : Duration := 0.0; + S : String (1..12) := "Ada 9X rules"; + end record; + -- predefined equality checks that all components are equal + + function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean; + -- primitive equality checks that records equate in component S only + +end C452001_3; + +with Report; +package body C452001_3 is + + procedure Change (Object : in out Tagged_Partial_Tagged_Full; + Value : in Boolean) is + begin + Object := (Report.Ident_Bool(Value), Object.C); + end Change; + + procedure Change (Object : in out Untagged_Partial_Tagged_Full; + Value : in Integer) is + begin + Object := (Report.Ident_Int(Value), Object.P); + end Change; + + procedure Change (Object : in out Untagged_Partial_Untagged_Full; + Value : in Duration) is + begin + Object := (Value, Report.Ident_Str(Object.S)); + end Change; + + function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean is + begin + return L.C = R.C; + end "="; + + function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean is + begin + return L.P = R.P; + end "="; + + function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean is + begin + return R.S = L.S; + end "="; + +end C452001_3; + + +with C452001_0; +with C452001_1; +with C452001_2; +with C452001_3; +with Report; +procedure C452001 is + + Mars_Aphelion : C452001_1.Planet := + (Name => "Mars ", + Representation => (Center => (Report.Ident_Int(20), + Report.Ident_Int(0)), + Radius => Report.Ident_Int(4), + Color => C452001_0.Red)); + + Mars_Perihelion : C452001_1.Planet := + (Name => "Mars ", + Representation => (Center => (Report.Ident_Int(-20), + Report.Ident_Int(0)), + Radius => Report.Ident_Int(4), + Color => C452001_0.Red)); + + -- Mars_Perihelion = Mars_Aphelion if user-defined equality from + -- the tagged type Colored_Circle was incorporated into + -- predefined equality for the tagged type Planet. User-defined + -- equality for Colored_Circle checks only that the Radii are equal. + + Blue_Mars : C452001_1.Planet := + (Name => "Mars ", + Representation => (Center => (Report.Ident_Int(10), + Report.Ident_Int(10)), + Radius => Report.Ident_Int(4), + Color => C452001_0.Blue)); + + -- Blue_Mars should equal Mars_Perihelion, because Names and + -- Radii are equal (all other components are not). + + Green_Mars : C452001_1.Planet := + (Name => "Mars ", + Representation => (Center => (Report.Ident_Int(10), + Report.Ident_Int(10)), + Radius => Report.Ident_Int(4), + Color => C452001_0.Green)); + + -- Blue_Mars should equal Green_Mars. They differ only in the + -- Color component. All user-defined equality operations return + -- True, but records are not equal by predefined equality. + + -- Blue_Mars should equal Mars_Perihelion, because Names and + -- Radii are equal (all other components are not). + + Moon_Craters : C452001_1.Craters := + ((Center => (Report.Ident_Int(9), Report.Ident_Int(11)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Black), + (Center => (Report.Ident_Int(10), Report.Ident_Int(10)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Black), + (Center => (Report.Ident_Int(11), Report.Ident_Int(9)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Black)); + + Alternate_Moon_Craters : C452001_1.Craters := + ((Center => (Report.Ident_Int(9), Report.Ident_Int(9)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Yellow), + (Center => (Report.Ident_Int(10), Report.Ident_Int(10)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Purple), + (Center => (Report.Ident_Int(11), Report.Ident_Int(11)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Purple)); + + -- Moon_Craters = Alternate_Moon_Craters if user-defined equality from + -- the tagged type Colored_Circle was incorporated into + -- predefined equality for the untagged type Craters. User-defined + -- equality checks only that the Radii are equal. + + New_Moon : C452001_1.Moon := + (Name => "Moon ", + Representation => (Center => (Report.Ident_Int(10), + Report.Ident_Int(8)), + Radius => Report.Ident_Int(3), + Color => C452001_0.Black), + Crater => Moon_Craters); + + Full_Moon : C452001_1.Moon := + (Name => "Moon ", + Representation => (Center => (Report.Ident_Int(10), + Report.Ident_Int(8)), + Radius => Report.Ident_Int(3), + Color => C452001_0.Black), + Crater => Alternate_Moon_Craters); + + -- New_Moon = Full_Moon if user-defined equality from + -- the tagged type Colored_Circle was incorporated into + -- predefined equality for the untagged type Craters. This + -- equality test should call user-defined equality for type + -- TC_Planet (checks that Names are equal), then predefined + -- equality for Craters (ultimately calls user-defined equality + -- for type Circle, checking that Radii of craters are equal). + + Mars_Moon : C452001_1.Moon := + (Name => "Phobos ", + Representation => (Center => (Report.Ident_Int(10), + Report.Ident_Int(8)), + Radius => Report.Ident_Int(3), + Color => C452001_0.Black), + Crater => Alternate_Moon_Craters); + + -- Mars_Moon /= Full_Moon since the Names differ. + + Alternate_Moon_Craters_2 : C452001_1.Craters := + ((Center => (Report.Ident_Int(10), Report.Ident_Int(10)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Red), + (Center => (Report.Ident_Int(9), Report.Ident_Int(9)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Red), + (Center => (Report.Ident_Int(10), Report.Ident_Int(9)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Red)); + + Harvest_Moon : C452001_1.Moon := + (Name => "Moon ", + Representation => (Center => (Report.Ident_Int(11), + Report.Ident_Int(7)), + Radius => Report.Ident_Int(4), + Color => C452001_0.Orange), + Crater => Alternate_Moon_Craters_2); + + -- Only the fields that are employed by the user-defined equality + -- operators are the same. Everything else differs. Equality should + -- still return True. + + Viking_1_Orbiter : C452001_2.Mission := + (Craft => (Design => C452001_2.Viking, + Operational => Report.Ident_Bool(False)), + Launch_Date => 1975); + + Viking_1_Lander : C452001_2.Mission := + (Craft => (Design => C452001_2.Viking, + Operational => Report.Ident_Bool(True)), + Launch_Date => 1975); + + -- Viking_1_Orbiter /= Viking_1_Lander if predefined equality + -- from the untagged type Spacecraft is used for equality + -- of matching components in type Mission. If user-defined + -- equality for type Spacecraft is incorporated, which it + -- should not be by 4.5.2(21), then Viking_1_Orbiter = Viking_1_Lander. + + Voyagers : C452001_2.Inventory (1..2):= + ((C452001_2.Voyager, Operational => Report.Ident_Bool(True)), + (C452001_2.Voyager, Operational => Report.Ident_Bool(False))); + + Jupiter_Craft : C452001_2.Inventory (1..2):= + ((C452001_2.Voyager, Operational => Report.Ident_Bool(True)), + (C452001_2.Voyager, Operational => Report.Ident_Bool(True))); + + -- Voyagers /= Jupiter_Craft if predefined equality + -- from the untagged type Spacecraft is used for equality + -- of matching components in type Inventory. If user-defined + -- equality for type Spacecraft is incorporated, which it + -- should not be by 4.5.2(21), then Voyagers = Jupiter_Craft. + + TPTF_1 : C452001_3.Tagged_Partial_Tagged_Full; + TPTF_2 : C452001_3.Tagged_Partial_Tagged_Full; + + -- With differing values for Boolean component, user-defined + -- (primitive) equality returns True, predefined equality + -- returns False. Since full type is tagged, primitive equality + -- should be used. + + UPTF_1 : C452001_3.Untagged_Partial_Tagged_Full; + UPTF_2 : C452001_3.Untagged_Partial_Tagged_Full; + + -- With differing values for Boolean component, user-defined + -- (primitive) equality returns True, predefined equality + -- returns False. Since full type is tagged, primitive equality + -- should be used. + + UPUF_1 : C452001_3.Untagged_Partial_Untagged_Full; + UPUF_2 : C452001_3.Untagged_Partial_Untagged_Full; + + -- With differing values for Duration component, user-defined + -- (primitive) equality returns True, predefined equality + -- returns False. Since full type is untagged, predefined equality + -- should be used. + + -- Use type clauses make "=" and "/=" operators directly visible + use type C452001_1.Planet; + use type C452001_1.Craters; + use type C452001_1.Moon; + use type C452001_2.Mission; + use type C452001_2.Inventory; + use type C452001_3.Tagged_Partial_Tagged_Full; + use type C452001_3.Untagged_Partial_Tagged_Full; + use type C452001_3.Untagged_Partial_Untagged_Full; + +begin + + Report.Test ("C452001", "Equality of private types and " & + "composite types with tagged components"); + + ------------------------------------------------------------------- + -- Tagged type with tagged component. + ------------------------------------------------------------------- + + if not (Mars_Aphelion = Mars_Perihelion) then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined equality " & + "for enclosing tagged record type"); + end if; + + if Mars_Aphelion /= Mars_Perihelion then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined inequality " & + "for enclosing tagged record type"); + end if; + + if not (Blue_Mars = Mars_Perihelion) then + Report.Failed ("Equality test for tagged record type " & + "incorporates record components " & + "other than those used by user-defined equality"); + end if; + + if Blue_Mars /= Mars_Perihelion then + Report.Failed ("Inequality test for tagged record type " & + "incorporates record components " & + "other than those used by user-defined equality"); + end if; + + if Blue_Mars /= Green_Mars then + Report.Failed ("Records are unequal even though they only differ " & + "in a component not used by user-defined equality"); + end if; + + if not (Blue_Mars = Green_Mars) then + Report.Failed ("Records are not equal even though they only differ " & + "in a component not used by user-defined equality"); + end if; + + ------------------------------------------------------------------- + -- Untagged (array) type with tagged component. + ------------------------------------------------------------------- + + if not (Moon_Craters = Alternate_Moon_Craters) then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined equality " & + "for enclosing array type"); + end if; + + if Moon_Craters /= Alternate_Moon_Craters then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined inequality " & + "for enclosing array type"); + end if; + + ------------------------------------------------------------------- + -- Tagged type with untagged composite component. Untagged + -- component itself has tagged components. + ------------------------------------------------------------------- + if not (New_Moon = Full_Moon) then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined equality " & + "for array component of tagged record type"); + end if; + + if New_Moon /= Full_Moon then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined inequality " & + "for array component of tagged record type"); + end if; + + if Mars_Moon = Full_Moon then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined equality " & + "for array component of tagged record type"); + end if; + + if not (Mars_Moon /= Full_Moon) then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined inequality " & + "for array component of tagged record type"); + end if; + + if not (Harvest_Moon = Full_Moon) then + Report.Failed ("Equality test for record with array of tagged " & + "components incorporates record components " & + "other than those used by user-defined equality"); + end if; + + if Harvest_Moon /= Full_Moon then + Report.Failed ("Inequality test for record with array of tagged " & + "components incorporates record components " & + "other than those used by user-defined equality"); + end if; + + ------------------------------------------------------------------- + -- Untagged types with no tagged components. + ------------------------------------------------------------------- + + -- Record type + + if Viking_1_Orbiter = Viking_1_Lander then + Report.Failed ("User-defined equality for untagged composite " & + "component was incorporated into predefined " & + "equality for " & + "untagged record type"); + end if; + + if not (Viking_1_Orbiter /= Viking_1_Lander) then + Report.Failed ("User-defined equality for untagged composite " & + "component was incorporated into predefined " & + "inequality for " & + "untagged record type"); + end if; + + -- Array type + + if Voyagers = Jupiter_Craft then + Report.Failed ("User-defined equality for untagged composite " & + "component was incorporated into predefined " & + "equality for " & + "array type"); + end if; + + if not (Voyagers /= Jupiter_Craft) then + Report.Failed ("User-defined equality for untagged composite " & + "component was incorporated into predefined " & + "inequality for " & + "array type"); + end if; + + ------------------------------------------------------------------- + -- Private types tests. + ------------------------------------------------------------------- + + -- Make objects differ from one another + + C452001_3.Change (TPTF_1, False); + C452001_3.Change (UPTF_1, 999); + C452001_3.Change (UPUF_1, 40.0); + + ------------------------------------------------------------------- + -- Partial type and full type are tagged. (Full type must be tagged + -- if partial type is tagged) + ------------------------------------------------------------------- + + if not (TPTF_1 = TPTF_2) then + Report.Failed ("Predefined equality for full type " & + "was used to determine equality of " & + "tagged private type " & + "instead of user-defined (primitive) equality"); + end if; + + if TPTF_1 /= TPTF_2 then + Report.Failed ("Predefined equality for full type " & + "was used to determine inequality of " & + "tagged private type " & + "instead of user-defined (primitive) equality"); + end if; + + ------------------------------------------------------------------- + -- Partial type untagged, full type tagged. + ------------------------------------------------------------------- + + if not (UPTF_1 = UPTF_2) then + Report.Failed ("Predefined equality for full type " & + "was used to determine equality of " & + "private type (untagged partial view, " & + "tagged full view) " & + "instead of user-defined (primitive) equality"); + end if; + + if UPTF_1 /= UPTF_2 then + Report.Failed ("Predefined equality for full type " & + "was used to determine inequality of " & + "private type (untagged partial view, " & + "tagged full view) " & + "instead of user-defined (primitive) equality"); + end if; + + ------------------------------------------------------------------- + -- Partial type and full type are both untagged. + ------------------------------------------------------------------- + + if UPUF_1 = UPUF_2 then + Report.Failed ("User-defined (primitive) equality for full type " & + "was used to determine equality of " & + "private type (untagged partial view, " & + "untagged full view) " & + "instead of predefined equality"); + end if; + + if not (UPUF_1 /= UPUF_2) then + Report.Failed ("User-defined (primitive) equality for full type " & + "was used to determine inequality of " & + "private type (untagged partial view, " & + "untagged full view) " & + "instead of predefined equality"); + end if; + + ------------------------------------------------------------------- + Report.Result; + +end C452001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45201a.ada b/gcc/testsuite/ada/acats/tests/c4/c45201a.ada new file mode 100644 index 000000000..5c1970d34 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45201a.ada @@ -0,0 +1,242 @@ +-- C45201A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT '=' AND '/=' PRODUCE CORRECT RESULTS ON +-- ENUMERATION-TYPE OPERANDS (IN PARTICULAR, FOR OPERANDS HAVING +-- DIFFERENT SUBTYPES). + +-- THIS TEST'S FRAMEWORK IS FROM C45201B.ADA , C45210A.ADA . + + +-- RM 20 OCTOBER 1980 +-- JWC 7/8/85 RENAMED TO -AB + + +WITH REPORT ; +PROCEDURE C45201A IS + + USE REPORT; + + TYPE T IS ( A , SLIT , B , PLIT , C , NUL , D , 'R' , E ); + + -- S-LIT , P-LIT , NUL , 'R' CORRESPOND + -- TO 'S' , 'P' , 'M' , 'R' IN C45210A. + + SUBTYPE T1 IS T RANGE A..B ; + SUBTYPE T2 IS T RANGE A..C ; -- INCLUDES T1 + SUBTYPE T3 IS T RANGE B..D ; -- INTERSECTS T2 , T4 + SUBTYPE T4 IS T RANGE C..E ; -- DISJOINT FROM T1 , T2 + + MVAR : T3 := T'(NUL ) ; + PVAR : T2 := T'(PLIT) ; + RVAR : T4 := T'('R' ) ; + SVAR : T1 := T'(SLIT) ; + + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + FUNCTION ITSELF( THE_ARGUMENT : T ) RETURN T IS + BEGIN + IF EQUAL(2,2) THEN RETURN THE_ARGUMENT; + ELSE RETURN A ; + END IF; + END ; + + +BEGIN + + TEST( "C45201A" , "CHECK THAT '=' AND '/=' PRODUCE CORRECT" & + " RESULTS ON ENUMERATION-TYPE LITERALS" ) ; + + -- 128 CASES ( 4 * 4 ORDERED PAIRS OF OPERAND VALUES, + -- 2 (4) OPERATORS (2, TWICE): '=' , '/=' , '=' , '/=' + -- (IN THE TABLE: A , B , C , D ) + -- (C45201B.ADA HAD < <= > >= ; REVERSED) + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND, + -- (IN THE TABLE: VV = ALPHA , + -- VL = BETA , + -- LV = GAMMA , + -- LL = DELTA ) RANDOMIZED + -- INTO 16 (ONE FOR EACH PAIR OF VALUES) ACCORDING TO THE FOL- + -- LOWING GRAECO-LATIN SQUARE (WITH ADDITIONAL PROPERTIES): + + -- RIGHT OPERAND: 'S' 'P' 'M' 'R' + -- LEFT + -- OPERAND: + + -- 'S' A-ALPHA B-BETA C-GAMMA D-DELTA + -- 'P' C-DELTA D-GAMMA A-BETA B-ALPHA + -- 'M' D-BETA C-ALPHA B-DELTA A-GAMMA + -- 'R' B-GAMMA A-DELTA D-ALPHA C-BETA + + -- (BOTH THE LATIN DIAGONAL AND THE GREEK DIAGONAL CONTAIN 4 + -- DISTINCT LETTERS, NON-TRIVIALLY PERMUTED.) + + -- THE ABOVE DESCRIBES PART 1 OF THE TEST. PART 2 PERFORMS AN + -- EXHAUSTIVE VERIFICATION OF THE 'VARIABLE VS. VARIABLE' CASE + -- ( VV , ALPHA ) FOR BOTH OPERATORS. + + ----------------------------------------------------------------- + + -- PART 1 + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + IF T'(SVAR) = T'(SVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(SVAR) /= T'(PLIT) THEN NULL; ELSE BUMP ; END IF; + IF T'(SLIT) = T'(MVAR) THEN BUMP ; END IF; + IF T'(SLIT) /= T'('R' ) THEN NULL; ELSE BUMP ; END IF; + + IF T'(PLIT) = T'(SLIT) THEN BUMP ; END IF; + IF T'(PLIT) /= T'(PVAR) THEN BUMP ; END IF; + IF T'(PVAR) = T'(NUL ) THEN BUMP ; END IF; + IF T'(PVAR) /= T'(RVAR) THEN NULL; ELSE BUMP ; END IF; + + IF T'(MVAR) /= T'(SLIT) THEN NULL; ELSE BUMP ; END IF; + IF T'(MVAR) = T'(PVAR) THEN BUMP ; END IF; + IF T'(NUL ) /= T'(NUL ) THEN BUMP ; END IF; + IF T'(NUL ) = T'(RVAR) THEN BUMP ; END IF; + + IF T'('R' ) /= T'(SVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'('R' ) = T'(PLIT) THEN BUMP ; END IF; + IF T'(RVAR) /= T'(MVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(RVAR) = T'('R' ) THEN NULL; ELSE BUMP ; END IF; + + + IF ERROR_COUNT /= 0 THEN + FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE1" ); + END IF; + + ----------------------------------------------------------------- + + -- PART 2 + + -- 'BUMP' STILL MEANS 'BUMP THE ERROR COUNT' + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + FOR BVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + + IF AVAR = BVAR THEN + IF AVAR /= BVAR THEN BUMP ; END IF; + END IF; + + IF AVAR /= BVAR THEN + IF AVAR = BVAR THEN BUMP ; END IF; + END IF; + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 0 THEN + FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE2" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + + FOR BVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + + IF ( AVAR /= BVAR ) /= ( T'POS(AVAR) /= T'POS(BVAR) )THEN + BUMP ; + END IF; + + IF ( AVAR = BVAR ) /= ( T'POS(AVAR) = T'POS(BVAR) )THEN + BUMP ; + END IF; + + END LOOP; + + END LOOP; + + IF ERROR_COUNT /= 0 THEN + FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE3" ); + END IF; + + ERROR_COUNT := 0 ; + + FOR IVAR IN 0..8 LOOP -- 9 VALUES + + FOR JVAR IN 0..8 LOOP -- 9 VALUES + + IF ( IVAR /= JVAR ) /= ( T'VAL(IVAR) /= T'VAL(JVAR) )THEN + BUMP ; + END IF; + + IF ( IVAR = JVAR ) /= ( T'VAL(IVAR) = T'VAL(JVAR) )THEN + BUMP ; + END IF; + + END LOOP; + + END LOOP; + + IF ERROR_COUNT /= 0 THEN + FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE4" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES (THE DIAGONAL) + + IF AVAR = ITSELF(AVAR) THEN NULL; ELSE BUMP; END IF; + IF AVAR /= ITSELF(AVAR) THEN BUMP; END IF; + + END LOOP; + + IF ERROR_COUNT /= 0 THEN + FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE5" ); + END IF; + + + -- 'BUMP' MEANS 'INCREASE THE COUNT FOR THE NUMBER OF <TRUE>S' + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + FOR BVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + + IF AVAR /= BVAR THEN BUMP ; END IF; -- COUNT +:= 72 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 72 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE6" ); + END IF; + + + RESULT; + +END C45201A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45201b.ada b/gcc/testsuite/ada/acats/tests/c4/c45201b.ada new file mode 100644 index 000000000..7c64c8bf4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45201b.ada @@ -0,0 +1,236 @@ +-- C45201B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE ORDERING OF ENUMERATION LITERALS AS DEFINED BY THE +-- ORDERING OPERATORS IS THE SAME AS THE ORDER OF OCCURRENCE OF THE +-- LITERALS IN THE TYPE DEFINITION. + +-- THIS TEST IS DERIVED FROM C45210A.ADA . + + +-- RM 17 OCTOBER 1980 +-- JWC 7/8/85 RENAMED TO -AB + + +WITH REPORT ; +PROCEDURE C45201B IS + + USE REPORT; + + TYPE T IS ( A , SLIT , B , PLIT , C , NUL , D , 'R' , E ); + + -- S-LIT , P-LIT , NUL , 'R' CORRESPOND + -- TO 'S' , 'P' , 'M' , 'R' IN C45210A. + + SUBTYPE T1 IS T RANGE A..B ; + SUBTYPE T2 IS T RANGE A..C ; -- INCLUDES T1 + SUBTYPE T3 IS T RANGE B..D ; -- INTERSECTS T2 , T4 + SUBTYPE T4 IS T RANGE C..E ; -- DISJOINT FROM T1 , T2 + + MVAR : T3 := T'(NUL ) ; + PVAR : T2 := T'(PLIT) ; + RVAR : T4 := T'('R' ) ; + SVAR : T1 := T'(SLIT) ; + + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + +BEGIN + + TEST( "C45201B","CHECK THAT THE ORDERING OF ENUMERATION LITERALS "& + " AS DEFINED BY THE ORDERING OPERATORS" & + " IS THE SAME AS THE ORDER OF OCCURRENCE OF THE " & + " LITERALS IN THE TYPE DEFINITION" ) ; + + -- 256 CASES ( 4 * 4 ORDERED PAIRS OF OPERAND VALUES, + -- 4 ORDERING OPERATORS: '<' , '<=' , '>' , '>=' + -- (IN THE TABLE: A , B , C , D ) + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND, + -- (IN THE TABLE: VV = ALPHA , + -- VL = BETA , + -- LV = GAMMA , + -- LL = DELTA ) RANDOMIZED + -- INTO 16 (ONE FOR EACH PAIR OF VALUES) ACCORDING TO THE FOL- + -- LOWING GRAECO-LATIN SQUARE (WITH ADDITIONAL PROPERTIES): + + -- RIGHT OPERAND: 'S' 'P' 'M' 'R' + -- LEFT + -- OPERAND: + + -- 'S' A-ALPHA B-BETA C-GAMMA D-DELTA + -- 'P' C-DELTA D-GAMMA A-BETA B-ALPHA + -- 'M' D-BETA C-ALPHA B-DELTA A-GAMMA + -- 'R' B-GAMMA A-DELTA D-ALPHA C-BETA + + -- (BOTH THE LATIN DIAGONAL AND THE GREEK DIAGONAL CONTAIN 4 + -- DISTINCT LETTERS, NON-TRIVIALLY PERMUTED.) + + -- THE ABOVE DESCRIBES PART 1 OF THE TEST. PART 2 PERFORMS AN + -- EXHAUSTIVE VERIFICATION OF THE 'VARIABLE VS. VARIABLE' CASE + -- ( VV , ALPHA ) FOR ALL 4 OPERATORS. + + ----------------------------------------------------------------- + + -- PART 1 + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + IF T'(SVAR) < T'(SVAR) THEN BUMP ; END IF; + IF T'(SVAR) <= T'(PLIT) THEN NULL; ELSE BUMP ; END IF; + IF T'(SLIT) > T'(MVAR) THEN BUMP ; END IF; + IF T'(SLIT) >= T'('R' ) THEN BUMP ; END IF; + + IF T'(PLIT) > T'(SLIT) THEN NULL; ELSE BUMP ; END IF; + IF T'(PLIT) >= T'(PVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(PVAR) < T'(NUL ) THEN NULL; ELSE BUMP ; END IF; + IF T'(PVAR) <= T'(RVAR) THEN NULL; ELSE BUMP ; END IF; + + IF T'(MVAR) >= T'(SLIT) THEN NULL; ELSE BUMP ; END IF; + IF T'(MVAR) > T'(PVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(NUL ) <= T'(NUL ) THEN NULL; ELSE BUMP ; END IF; + IF T'(NUL ) < T'(RVAR) THEN NULL; ELSE BUMP ; END IF; + + IF T'('R' ) <= T'(SVAR) THEN BUMP ; END IF; + IF T'('R' ) < T'(PLIT) THEN BUMP ; END IF; + IF T'(RVAR) >= T'(MVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(RVAR) > T'('R' ) THEN BUMP ; END IF; + + + IF ERROR_COUNT /= 0 THEN + FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE1" ); + END IF; + + ----------------------------------------------------------------- + + -- PART 2 + + -- 'BUMP' MEANS 'INCREASE THE COUNT FOR THE NUMBER OF <TRUE>S' + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + FOR BVAR IN T'FIRST..T'(PLIT) LOOP -- 4 VALUES + + IF AVAR < BVAR THEN BUMP ; END IF; -- COUNT +:= 6 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 6 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE2" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + FOR BVAR IN T'FIRST..T'(PLIT) LOOP -- 4 VALUES + + IF AVAR <= BVAR THEN BUMP ; END IF; -- COUNT +:= 10 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /=10 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE3" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + FOR BVAR IN T'FIRST..T'(PLIT) LOOP -- 4 VALUES + + IF AVAR > BVAR THEN BUMP ; END IF; -- COUNT +:= 26 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /=26 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE4" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + FOR BVAR IN T'FIRST..T'(PLIT) LOOP -- 4 VALUES + + IF AVAR >= BVAR THEN BUMP ; END IF; -- COUNT +:= 30 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /=30 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE5" ); + END IF; + + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' (AGAIN) + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + + FOR BVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + + IF ( AVAR < BVAR ) /= ( T'POS(AVAR) < T'POS(BVAR) )THEN + BUMP ; + END IF; + + IF ( AVAR <= BVAR ) /= ( T'POS(AVAR) <= T'POS(BVAR) )THEN + BUMP ; + END IF; + + IF ( AVAR > BVAR ) /= ( T'POS(AVAR) > T'POS(BVAR) )THEN + BUMP ; + END IF; + + IF ( AVAR >= BVAR ) /= ( T'POS(AVAR) >= T'POS(BVAR) )THEN + BUMP ; + END IF; + + END LOOP; + + END LOOP; + + + IF ERROR_COUNT /= 0 THEN -- REAL ERROR COUNT AGAIN + FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE6" ); + END IF; + + + RESULT; + +END C45201B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45202b.ada b/gcc/testsuite/ada/acats/tests/c4/c45202b.ada new file mode 100644 index 000000000..bf2a02fef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45202b.ada @@ -0,0 +1,95 @@ +-- C45202B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK MEMBERSHIP OPERATIONS IN THE CASE IN WHICH A USER HAS +-- REDEFINED THE ORDERING OPERATORS. + +-- RJW 1/22/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C45202B IS + + +BEGIN + + TEST( "C45202B" , "CHECK MEMBERSHIP OPERATIONS IN WHICH A USER " & + "HAS REDEFINED THE ORDERING OPERATORS" ) ; + + + DECLARE + + TYPE T IS ( AA, BB, CC, LIT, XX, YY, ZZ ); + SUBTYPE ST IS T RANGE AA .. LIT; + + VAR : T := LIT ; + CON : CONSTANT T := LIT ; + + FUNCTION ">" ( L, R : T ) RETURN BOOLEAN IS + BEGIN + RETURN T'POS(L) <= T'POS(R); + END; + + FUNCTION ">=" ( L, R : T ) RETURN BOOLEAN IS + BEGIN + RETURN T'POS(L) < T'POS(R); + END; + + FUNCTION "<" ( L, R : T ) RETURN BOOLEAN IS + BEGIN + RETURN T'POS(L) >= T'POS(R); + END; + + FUNCTION "<=" ( L, R : T ) RETURN BOOLEAN IS + BEGIN + RETURN T'POS(L) > T'POS(R); + END; + + + BEGIN + + IF LIT NOT IN ST OR + VAR NOT IN ST OR + CON NOT IN ST OR + NOT (VAR IN ST) OR + XX IN ST OR + NOT (XX NOT IN ST) + THEN + FAILED( "WRONG VALUES FOR 'IN ST'" ); + END IF; + + IF LIT IN AA ..CC OR + VAR NOT IN LIT..ZZ OR + CON IN ZZ ..AA OR + NOT (CC IN CC .. YY) OR + NOT (BB NOT IN CC .. YY) + THEN + FAILED( "WRONG VALUES FOR 'IN AA..CC'" ); + END IF; + + END; + + RESULT; + +END C45202B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45210a.ada b/gcc/testsuite/ada/acats/tests/c4/c45210a.ada new file mode 100644 index 000000000..e7461aa8d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45210a.ada @@ -0,0 +1,191 @@ +-- C45210A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT AN ENUMERATION IMPOSING AN "UNNATURAL" ORDER ON ALPHABETIC +-- CHARACTERS CORRECTLY EVALUATES THE ORDERING OPERATORS. + + +-- RM 15 OCTOBER 1980 +-- JWC 7/8/85 RENAMED TO -AB + + +WITH REPORT ; +PROCEDURE C45210A IS + + USE REPORT; + + TYPE T IS ( 'S' , 'P' , 'M' , 'R' ); + + MVAR : T := T'('M') ; + PVAR : T := T'('P') ; + RVAR : T := T'('R') ; + SVAR : T := T'('S') ; + + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT +1 ; + END BUMP ; + + +BEGIN + + TEST( "C45210A" , "CHECK THAT AN ENUMERATION IMPOSING" & + " AN ""UNNATURAL"" ORDER ON ALPHABETIC" & + " CHARACTERS CORRECTLY EVALUATES THE " & + " ORDERING OPERATORS" ) ; + + -- 256 CASES ( 4 * 4 ORDERED PAIRS OF OPERAND VALUES, + -- 4 ORDERING OPERATORS: '<' , '<=' , '>' , '>=' + -- (IN THE TABLE: A , B , C , D ) + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND, + -- (IN THE TABLE: VV = ALPHA , + -- VL = BETA , + -- LV = GAMMA , + -- LL = DELTA ) RANDOMIZED + -- INTO 16 (ONE FOR EACH PAIR OF VALUES) ACCORDING TO THE FOL- + -- LOWING GRAECO-LATIN SQUARE (WITH ADDITIONAL PROPERTIES): + + -- RIGHT OPERAND: 'S' 'P' 'M' 'R' + -- LEFT + -- OPERAND: + + -- 'S' A-ALPHA B-BETA C-GAMMA D-DELTA + -- 'P' C-DELTA D-GAMMA A-BETA B-ALPHA + -- 'M' D-BETA C-ALPHA B-DELTA A-GAMMA + -- 'R' B-GAMMA A-DELTA D-ALPHA C-BETA + + -- (BOTH THE LATIN DIAGONAL AND THE GREEK DIAGONAL CONTAIN 4 + -- DISTINCT LETTERS, NON-TRIVIALLY PERMUTED.) + + -- THE ABOVE DESCRIBES PART 1 OF THE TEST. PART 2 PERFORMS AN + -- EXHAUSTIVE VERIFICATION OF THE 'VARIABLE VS. VARIABLE' CASE + -- ( VV , ALPHA ) FOR ALL 4 OPERATORS. + + ----------------------------------------------------------------- + + -- PART 1 + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + IF T'(SVAR) < T'(SVAR) THEN BUMP ; END IF; + IF T'(SVAR) <= T'('P' ) THEN NULL; ELSE BUMP ; END IF; + IF T'('S' ) > T'(MVAR) THEN BUMP ; END IF; + IF T'('S' ) >= T'('R' ) THEN BUMP ; END IF; + + IF T'('P' ) > T'('S' ) THEN NULL; ELSE BUMP ; END IF; + IF T'('P' ) >= T'(PVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(PVAR) < T'('M' ) THEN NULL; ELSE BUMP ; END IF; + IF T'(PVAR) <= T'(RVAR) THEN NULL; ELSE BUMP ; END IF; + + IF T'(MVAR) >= T'('S' ) THEN NULL; ELSE BUMP ; END IF; + IF T'(MVAR) > T'(PVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'('M' ) <= T'('M' ) THEN NULL; ELSE BUMP ; END IF; + IF T'('M' ) < T'(RVAR) THEN NULL; ELSE BUMP ; END IF; + + IF T'('R' ) <= T'(SVAR) THEN BUMP ; END IF; + IF T'('R' ) < T'('P' ) THEN BUMP ; END IF; + IF T'(RVAR) >= T'(MVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(RVAR) > T'('R' ) THEN BUMP ; END IF; + + + IF ERROR_COUNT /= 0 THEN + FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE1" ); + END IF; + + ----------------------------------------------------------------- + + -- PART 2 + + -- 'BUMP' MEANS 'INCREASE THE COUNT FOR THE NUMBER OF <TRUE>S' + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 4 VALUES + FOR BVAR IN T'FIRST..T'('P') LOOP -- 2 VALUES + + IF AVAR < BVAR THEN BUMP ; END IF; -- COUNT +:= 1 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 1 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE2" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 4 VALUES + FOR BVAR IN T'FIRST..T'('P') LOOP -- 2 VALUES + + IF AVAR <= BVAR THEN BUMP ; END IF; -- COUNT +:= 3 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 3 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE3" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 4 VALUES + FOR BVAR IN T'FIRST..T'('P') LOOP -- 2 VALUES + + IF AVAR > BVAR THEN BUMP ; END IF; -- COUNT +:= 5 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 5 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE4" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 4 VALUES + FOR BVAR IN T'FIRST..T'('P') LOOP -- 2 VALUES + + IF AVAR >= BVAR THEN BUMP ; END IF; -- COUNT +:= 7 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 7 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE5" ); + END IF; + + + RESULT; + +END C45210A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45211a.ada b/gcc/testsuite/ada/acats/tests/c4/c45211a.ada new file mode 100644 index 000000000..8d73d771e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45211a.ada @@ -0,0 +1,66 @@ +-- C45211A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK MEMBERSHIP TESTS FOR AN 'UNNATURAL' ORDERING OF CHARACTER +-- LITERALS. + +-- RJW 1/22/86 + +WITH REPORT; USE REPORT; +PROCEDURE C45211A IS + + TYPE T IS ( 'S' , 'Q' , 'P' , 'M' , 'R' ); + SUBTYPE ST IS T RANGE 'P' .. 'R'; + + MVAR : T := T'('M') ; + QVAR : T := T'('Q') ; + MCON : CONSTANT T := T'('M'); + QCON : CONSTANT T := T'('Q'); + +BEGIN + + TEST( "C45211A" , "CHECK MEMBERSHIP TESTS FOR AN 'UNNATURAL' " & + "ORDERING OF CHARACTER LITERALS" ) ; + + IF QVAR IN T'('P') .. T'('R') OR + 'Q' IN ST + THEN + FAILED ( "MEMBERSHIP TEST FOR 'UNNATURAL' ORDERING - 1" ); + END IF; + + IF MVAR NOT IN T'('P') .. T'('R') OR + 'M' NOT IN ST + THEN + FAILED ( "MEMBERSHIP TEST FOR 'UNNATURAL' ORDERING - 2" ); + END IF; + + IF QCON IN T'('P') .. T'('R') OR + MCON NOT IN ST + THEN + FAILED ( "MEMBERSHIP TEST FOR 'UNNATURAL' ORDERING - 3" ); + END IF; + + RESULT; + +END C45211A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45220a.ada b/gcc/testsuite/ada/acats/tests/c4/c45220a.ada new file mode 100644 index 000000000..382ccbb6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45220a.ada @@ -0,0 +1,129 @@ +-- C45220A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT '=' AND '/=' PRODUCE CORRECT RESULTS ON +-- BOOLEAN-TYPE OPERANDS (IN PARTICULAR, FOR OPERANDS HAVING +-- DIFFERENT SUBTYPES). + +-- THIS TEST IS DERIVED FROM C45201A.ADA . + + +-- RM 27 OCTOBER 1980 +-- JWC 7/8/85 RENAMED TO -AB + + +WITH REPORT ; +PROCEDURE C45220A IS + + + USE REPORT; + + SUBTYPE T1 IS BOOLEAN RANGE FALSE..FALSE ; + SUBTYPE T2 IS BOOLEAN RANGE TRUE..TRUE ; + SUBTYPE T3 IS BOOLEAN RANGE FALSE..TRUE ; + SUBTYPE T4 IS T3 RANGE TRUE..TRUE ; + + FVAR1 : T1 := FALSE ; + TVAR1 : T2 := TRUE ; + FVAR2 : T3 := FALSE ; + TVAR2 : T4 := TRUE ; + + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + +BEGIN + + + TEST( "C45220A" , "CHECK THAT '=' AND '/=' PRODUCE CORRECT" & + " RESULTS ON BOOLEAN-TYPE OPERANDS" ) ; + + -- 32 CASES ( 2 * 2 ORDERED PAIRS OF OPERAND VALUES, + -- 2 OPERATORS : '=' , '/=' , + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND. + + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + FVAR1 := IDENT_BOOL( FALSE ) ; + TVAR1 := IDENT_BOOL( TRUE ) ; + FVAR2 := IDENT_BOOL( FALSE ) ; + TVAR2 := IDENT_BOOL( TRUE ) ; + + IF FALSE = FALSE THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 = FALSE THEN NULL ; ELSE BUMP ; END IF; + IF FALSE = FVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 = FVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF FALSE = TRUE THEN BUMP ; END IF; + IF FVAR1 = TRUE THEN BUMP ; END IF; + IF FALSE = TVAR2 THEN BUMP ; END IF; + IF FVAR2 = TVAR1 THEN BUMP ; END IF; + + IF TRUE = FALSE THEN BUMP ; END IF; + IF TRUE = FVAR1 THEN BUMP ; END IF; + IF TVAR2 = FALSE THEN BUMP ; END IF; + IF TVAR1 = FVAR2 THEN BUMP ; END IF; + + IF TRUE = TRUE THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 = TRUE THEN NULL ; ELSE BUMP ; END IF; + IF TRUE = TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 = TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + + IF FALSE /= FALSE THEN BUMP ; END IF; + IF FVAR1 /= FALSE THEN BUMP ; END IF; + IF FALSE /= FVAR2 THEN BUMP ; END IF; + IF FVAR2 /= FVAR1 THEN BUMP ; END IF; + + IF FALSE /= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 /= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF FALSE /= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 /= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF TRUE /= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF TRUE /= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 /= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 /= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + + IF TRUE /= TRUE THEN BUMP ; END IF; + IF TVAR1 /= TRUE THEN BUMP ; END IF; + IF TRUE /= TVAR2 THEN BUMP ; END IF; + IF TVAR2 /= TVAR1 THEN BUMP ; END IF; + + + IF ERROR_COUNT /=0 THEN + FAILED( "(IN)EQUALITY OF BOOLEAN VALUES - FAILURE1" ); + END IF; + + + RESULT ; + + +END C45220A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45220b.ada b/gcc/testsuite/ada/acats/tests/c4/c45220b.ada new file mode 100644 index 000000000..87ba73442 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45220b.ada @@ -0,0 +1,191 @@ +-- C45220B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT '<' , '<=' , '>' , '>=' PRODUCE CORRECT RESULTS ON +-- BOOLEAN-TYPE OPERANDS (IN PARTICULAR, FOR OPERANDS HAVING +-- DIFFERENT SUBTYPES). + +-- THIS TEST IS DERIVED FROM C45220A.ADA . + + +-- RM 28 OCTOBER 1980 +-- JWC 7/8/85 RENAMED TO -AB + + +WITH REPORT ; +PROCEDURE C45220B IS + + + USE REPORT; + + SUBTYPE T1 IS BOOLEAN RANGE FALSE..FALSE ; + SUBTYPE T2 IS BOOLEAN RANGE TRUE..TRUE ; + SUBTYPE T3 IS BOOLEAN RANGE FALSE..TRUE ; + SUBTYPE T4 IS T3 RANGE TRUE..TRUE ; + + FVAR1 : T1 := FALSE ; + TVAR1 : T2 := TRUE ; + FVAR2 : T3 := FALSE ; + TVAR2 : T4 := TRUE ; + + ERROR_COUNT : INTEGER := 0 ; + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + +BEGIN + + + TEST( "C45220B" , "CHECK THAT '<' , '<=' , '>' , '>=' PRODUCE" & + " CORRECT RESULTS ON BOOLEAN-TYPE OPERANDS" ) ; + + -- 64 CASES ( 2 * 2 ORDERED PAIRS OF OPERAND VALUES, + -- 4 OPERATORS : '<' , <=' , '>' , '>=' + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND. + + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + FVAR1 := IDENT_BOOL( FALSE ) ; + TVAR1 := IDENT_BOOL( TRUE ) ; + FVAR2 := IDENT_BOOL( FALSE ) ; + TVAR2 := IDENT_BOOL( TRUE ) ; + + + ERROR_COUNT := 0 ; + + IF FALSE < FALSE THEN BUMP ; END IF; + IF FVAR1 < FALSE THEN BUMP ; END IF; + IF FALSE < FVAR2 THEN BUMP ; END IF; + IF FVAR2 < FVAR1 THEN BUMP ; END IF; + + IF FALSE < TRUE THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 < TRUE THEN NULL ; ELSE BUMP ; END IF; + IF FALSE < TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 < TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF TRUE < FALSE THEN BUMP ; END IF; + IF TRUE < FVAR1 THEN BUMP ; END IF; + IF TVAR2 < FALSE THEN BUMP ; END IF; + IF TVAR1 < FVAR2 THEN BUMP ; END IF; + + IF TRUE < TRUE THEN BUMP ; END IF; + IF TVAR1 < TRUE THEN BUMP ; END IF; + IF TRUE < TVAR2 THEN BUMP ; END IF; + IF TVAR2 < TVAR1 THEN BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF BOOLEAN VALUES - FAILURE '<'" ); + END IF; + + + ERROR_COUNT := 0 ; + + IF FALSE <= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 <= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF FALSE <= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 <= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF FALSE <= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 <= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF FALSE <= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 <= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF TRUE <= FALSE THEN BUMP ; END IF; + IF TRUE <= FVAR1 THEN BUMP ; END IF; + IF TVAR2 <= FALSE THEN BUMP ; END IF; + IF TVAR1 <= FVAR2 THEN BUMP ; END IF; + + IF TRUE <= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 <= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF TRUE <= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 <= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF BOOLEAN VALUES - FAILURE '<='" ); + END IF; + + + ERROR_COUNT := 0 ; + + IF FALSE > FALSE THEN BUMP ; END IF; + IF FVAR1 > FALSE THEN BUMP ; END IF; + IF FALSE > FVAR2 THEN BUMP ; END IF; + IF FVAR2 > FVAR1 THEN BUMP ; END IF; + + IF FALSE > TRUE THEN BUMP ; END IF; + IF FVAR1 > TRUE THEN BUMP ; END IF; + IF FALSE > TVAR2 THEN BUMP ; END IF; + IF FVAR2 > TVAR1 THEN BUMP ; END IF; + + IF TRUE > FALSE THEN NULL ; ELSE BUMP ; END IF; + IF TRUE > FVAR1 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 > FALSE THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 > FVAR2 THEN NULL ; ELSE BUMP ; END IF; + + IF TRUE > TRUE THEN BUMP ; END IF; + IF TVAR1 > TRUE THEN BUMP ; END IF; + IF TRUE > TVAR2 THEN BUMP ; END IF; + IF TVAR2 > TVAR1 THEN BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF BOOLEAN VALUES - FAILURE '>'" ); + END IF; + + + ERROR_COUNT := 0 ; + + IF FALSE >= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 >= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF FALSE >= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 >= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF FALSE >= TRUE THEN BUMP ; END IF; + IF FVAR1 >= TRUE THEN BUMP ; END IF; + IF FALSE >= TVAR2 THEN BUMP ; END IF; + IF FVAR2 >= TVAR1 THEN BUMP ; END IF; + + IF TRUE >= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF TRUE >= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 >= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 >= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + + IF TRUE >= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 >= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF TRUE >= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 >= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF BOOLEAN VALUES - FAILURE '>='" ); + END IF; + + + RESULT ; + + +END C45220B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45220c.ada b/gcc/testsuite/ada/acats/tests/c4/c45220c.ada new file mode 100644 index 000000000..cb505f256 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45220c.ada @@ -0,0 +1,138 @@ +-- C45220C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT '=' AND '/=' PRODUCE CORRECT RESULTS ON +-- OPERANDS OF A TYPE DERIVED FROM THE TYPE 'BOOLEAN' +-- (IN PARTICULAR, FOR OPERANDS HAVING DIFFERENT SUBTYPES). + +-- THIS TEST IS DERIVED FROM C45220A.ADA . + + +-- RM 27 OCTOBER 1980 +-- JWC 7/8/85 RENAMED TO -AB + + +WITH REPORT ; +PROCEDURE C45220C IS + + + USE REPORT; + + TYPE NB IS NEW BOOLEAN ; + + SUBTYPE T1 IS NB RANGE NB'(FALSE)..NB'(FALSE) ; + SUBTYPE T2 IS NB RANGE NB'(TRUE )..NB'(TRUE ); + SUBTYPE T3 IS NB RANGE NB'(FALSE)..NB'(TRUE ); + SUBTYPE T4 IS T3 RANGE NB'(TRUE )..NB'(TRUE ); + + FVAR1 : T1 := NB'(FALSE) ; + TVAR1 : T2 := NB'(TRUE ); + FVAR2 : T3 := NB'(FALSE) ; + TVAR2 : T4 := NB'(TRUE ); + + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + FUNCTION IDENT_NEW_BOOL( THE_ARGUMENT : NB ) RETURN NB IS + BEGIN + IF EQUAL(2,2) THEN RETURN THE_ARGUMENT; + ELSE RETURN NB'(FALSE) ; + END IF; + END ; + + +BEGIN + + + TEST( "C45220C" , "CHECK THAT '=' AND '/=' PRODUCE CORRECT" & + " RESULTS ON DERIVED-BOOLEAN-TYPE OPERANDS" ) ; + + -- 32 CASES ( 2 * 2 ORDERED PAIRS OF OPERAND VALUES, + -- 2 OPERATORS : '=' , '/=' , + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND. + + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + FVAR1 := IDENT_NEW_BOOL( NB'(FALSE) ) ; + TVAR1 := IDENT_NEW_BOOL( NB'(TRUE )) ; + FVAR2 := IDENT_NEW_BOOL( NB'(FALSE) ) ; + TVAR2 := IDENT_NEW_BOOL( NB'(TRUE )) ; + + IF NB'(FALSE) = NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 = NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(FALSE) = FVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 = FVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(FALSE) = NB'(TRUE ) THEN BUMP ; END IF; + IF FVAR1 = NB'(TRUE ) THEN BUMP ; END IF; + IF NB'(FALSE) = TVAR2 THEN BUMP ; END IF; + IF FVAR2 = TVAR1 THEN BUMP ; END IF; + + IF NB'(TRUE ) = NB'(FALSE) THEN BUMP ; END IF; + IF NB'(TRUE ) = FVAR1 THEN BUMP ; END IF; + IF TVAR2 = NB'(FALSE) THEN BUMP ; END IF; + IF TVAR1 = FVAR2 THEN BUMP ; END IF; + + IF NB'(TRUE ) = NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 = NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(TRUE ) = TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 = TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + + IF NB'(FALSE) /= NB'(FALSE) THEN BUMP ; END IF; + IF FVAR1 /= NB'(FALSE) THEN BUMP ; END IF; + IF NB'(FALSE) /= FVAR2 THEN BUMP ; END IF; + IF FVAR2 /= FVAR1 THEN BUMP ; END IF; + + IF NB'(FALSE) /= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 /= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(FALSE) /= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 /= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(TRUE ) /= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(TRUE ) /= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 /= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 /= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(TRUE ) /= NB'(TRUE ) THEN BUMP ; END IF; + IF TVAR1 /= NB'(TRUE ) THEN BUMP ; END IF; + IF NB'(TRUE ) /= TVAR2 THEN BUMP ; END IF; + IF TVAR2 /= TVAR1 THEN BUMP ; END IF; + + + IF ERROR_COUNT /=0 THEN + FAILED( "(IN)EQUALITY OF N_BOOLEAN VALUES - FAILURE1" ); + END IF; + + + RESULT ; + + +END C45220C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45220d.ada b/gcc/testsuite/ada/acats/tests/c4/c45220d.ada new file mode 100644 index 000000000..752d1fcaa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45220d.ada @@ -0,0 +1,200 @@ +-- C45220D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT '<' , '<=' , '>' , '>=' PRODUCE CORRECT RESULTS ON +-- OPERANDS OF A TYPE DERIVED FROM THE TYPE 'BOOLEAN' +-- (IN PARTICULAR, FOR OPERANDS HAVING DIFFERENT SUBTYPES). + +-- THIS TEST IS DERIVED FROM C45220B.ADA , C45220C.ADA . + + +-- RM 28 OCTOBER 1980 +-- JWC 7/8/85 RENAMED TO -AB + +WITH REPORT ; +PROCEDURE C45220D IS + + + USE REPORT; + + TYPE NB IS NEW BOOLEAN ; + + SUBTYPE T1 IS NB RANGE NB'(FALSE)..NB'(FALSE) ; + SUBTYPE T2 IS NB RANGE NB'(TRUE )..NB'(TRUE ); + SUBTYPE T3 IS NB RANGE NB'(FALSE)..NB'(TRUE ); + SUBTYPE T4 IS T3 RANGE NB'(TRUE )..NB'(TRUE ); + + FVAR1 : T1 := NB'(FALSE) ; + TVAR1 : T2 := NB'(TRUE ); + FVAR2 : T3 := NB'(FALSE) ; + TVAR2 : T4 := NB'(TRUE ); + + ERROR_COUNT : INTEGER := 0 ; + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + FUNCTION IDENT_NEW_BOOL( THE_ARGUMENT : NB ) RETURN NB IS + BEGIN + IF EQUAL(2,2) THEN RETURN THE_ARGUMENT; + ELSE RETURN NB'(FALSE) ; + END IF; + END ; + + +BEGIN + + + TEST( "C45220D" , "CHECK THAT '<' , '<=' , '>' , '>=' PRODUCE" & + " CORRECT RESULTS ON DERIVED-BOOLEAN-TYPE" & + " OPERANDS" ) ; + + -- 64 CASES ( 2 * 2 ORDERED PAIRS OF OPERAND VALUES, + -- 4 OPERATORS : '<' , <=' , '>' , '>=' + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND. + + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + FVAR1 := IDENT_NEW_BOOL( NB'(FALSE) ) ; + TVAR1 := IDENT_NEW_BOOL( NB'(TRUE )) ; + FVAR2 := IDENT_NEW_BOOL( NB'(FALSE) ) ; + TVAR2 := IDENT_NEW_BOOL( NB'(TRUE )) ; + + + ERROR_COUNT := 0 ; + + IF NB'(FALSE) < NB'(FALSE) THEN BUMP ; END IF; + IF FVAR1 < NB'(FALSE) THEN BUMP ; END IF; + IF NB'(FALSE) < FVAR2 THEN BUMP ; END IF; + IF FVAR2 < FVAR1 THEN BUMP ; END IF; + + IF NB'(FALSE) < NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 < NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(FALSE) < TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 < TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(TRUE ) < NB'(FALSE) THEN BUMP ; END IF; + IF NB'(TRUE ) < FVAR1 THEN BUMP ; END IF; + IF TVAR2 < NB'(FALSE) THEN BUMP ; END IF; + IF TVAR1 < FVAR2 THEN BUMP ; END IF; + + IF NB'(TRUE ) < NB'(TRUE ) THEN BUMP ; END IF; + IF TVAR1 < NB'(TRUE ) THEN BUMP ; END IF; + IF NB'(TRUE ) < TVAR2 THEN BUMP ; END IF; + IF TVAR2 < TVAR1 THEN BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF N_BOOLEAN VALUES - FAILURE '<'" ); + END IF; + + + ERROR_COUNT := 0 ; + + IF NB'(FALSE) <= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 <= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(FALSE) <= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 <= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(FALSE) <= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 <= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(FALSE) <= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 <= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(TRUE ) <= NB'(FALSE) THEN BUMP ; END IF; + IF NB'(TRUE ) <= FVAR1 THEN BUMP ; END IF; + IF TVAR2 <= NB'(FALSE) THEN BUMP ; END IF; + IF TVAR1 <= FVAR2 THEN BUMP ; END IF; + + IF NB'(TRUE ) <= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 <= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(TRUE ) <= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 <= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF N_BOOLEAN VALUES - FAILURE '<='" ); + END IF; + + + ERROR_COUNT := 0 ; + + IF NB'(FALSE) > NB'(FALSE) THEN BUMP ; END IF; + IF FVAR1 > NB'(FALSE) THEN BUMP ; END IF; + IF NB'(FALSE) > FVAR2 THEN BUMP ; END IF; + IF FVAR2 > FVAR1 THEN BUMP ; END IF; + + IF NB'(FALSE) > NB'(TRUE ) THEN BUMP ; END IF; + IF FVAR1 > NB'(TRUE ) THEN BUMP ; END IF; + IF NB'(FALSE) > TVAR2 THEN BUMP ; END IF; + IF FVAR2 > TVAR1 THEN BUMP ; END IF; + + IF NB'(TRUE ) > NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(TRUE ) > FVAR1 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 > NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 > FVAR2 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(TRUE ) > NB'(TRUE ) THEN BUMP ; END IF; + IF TVAR1 > NB'(TRUE ) THEN BUMP ; END IF; + IF NB'(TRUE ) > TVAR2 THEN BUMP ; END IF; + IF TVAR2 > TVAR1 THEN BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF N_BOOLEAN VALUES - FAILURE '>'" ); + END IF; + + + ERROR_COUNT := 0 ; + + IF NB'(FALSE) >= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 >= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(FALSE) >= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 >= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(FALSE) >= NB'(TRUE ) THEN BUMP ; END IF; + IF FVAR1 >= NB'(TRUE ) THEN BUMP ; END IF; + IF NB'(FALSE) >= TVAR2 THEN BUMP ; END IF; + IF FVAR2 >= TVAR1 THEN BUMP ; END IF; + + IF NB'(TRUE ) >= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(TRUE ) >= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 >= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 >= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(TRUE ) >= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 >= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(TRUE ) >= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 >= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF N_BOOLEAN VALUES - FAILURE '>='" ); + END IF; + + + RESULT ; + + +END C45220D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45220e.ada b/gcc/testsuite/ada/acats/tests/c4/c45220e.ada new file mode 100644 index 000000000..0fbf5bfeb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45220e.ada @@ -0,0 +1,74 @@ +-- C45220E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THE PROPER OPERATION OF THE MEMBERSHIP OPERATORS 'IN' AND +-- 'NOT IN' FOR BOOLEAN TYPES. + + +-- RM 03/20/81 +-- SPS 10/26/82 + + +WITH REPORT; +PROCEDURE C45220E IS + + USE REPORT ; + +BEGIN + + TEST( "C45220E" , "CHECK THE PROPER OPERATION OF THE MEMBERSHIP" & + " OPERATORS 'IN' AND 'NOT IN' FOR" & + " BOOLEAN TYPES" ); + + DECLARE + + SUBTYPE SUBBOOL IS BOOLEAN RANGE FALSE..TRUE ; + + VAR : BOOLEAN := FALSE ; + CON : CONSTANT BOOLEAN := FALSE ; + + BEGIN + + IF TRUE NOT IN SUBBOOL OR + VAR NOT IN SUBBOOL OR + CON NOT IN SUBBOOL + THEN + FAILED( "WRONG VALUES FOR 'IN SUBBOOL'" ); + END IF; + + IF FALSE IN TRUE..FALSE OR + VAR NOT IN FALSE..TRUE OR + CON IN TRUE..TRUE + THEN + FAILED( "WRONG VALUES FOR 'IN AAA..BBB'" ); + END IF; + + + RESULT ; + + + END ; + + +END C45220E ; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45220f.ada b/gcc/testsuite/ada/acats/tests/c4/c45220f.ada new file mode 100644 index 000000000..3d557d95b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45220f.ada @@ -0,0 +1,67 @@ +-- C45220F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE MEMBERSHIP OPERATIONS WORK CORRECTLY FOR DERIVED +-- BOOLEAN TYPES. + +-- GLH 08/01/85 + +WITH REPORT; +PROCEDURE C45220F IS + + USE REPORT ; + +BEGIN + + TEST( "C45220F" , "CHECK MEMBERSHIP OPERATIONS FOR " & + "DERIVED BOOLEAN"); + + DECLARE + + TYPE NEWBOOL IS NEW BOOLEAN; + + VAR : NEWBOOL := FALSE ; + CON : CONSTANT NEWBOOL := FALSE ; + + BEGIN + + IF TRUE NOT IN NEWBOOL OR + VAR NOT IN NEWBOOL OR + CON NOT IN NEWBOOL + THEN + FAILED( "WRONG VALUES FOR 'IN NEWBOOL'" ); + END IF; + + IF NEWBOOL'(FALSE) IN TRUE..FALSE OR + VAR NOT IN FALSE..TRUE OR + CON IN TRUE..TRUE + THEN + FAILED( "WRONG VALUES FOR 'IN AAA..BBB'" ); + END IF; + + RESULT ; + + END ; + +END C45220F ; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45231a.ada b/gcc/testsuite/ada/acats/tests/c4/c45231a.ada new file mode 100644 index 000000000..d5fce67cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45231a.ada @@ -0,0 +1,252 @@ +-- C45231A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE RELATIONAL AND MEMBERSHIP OPERATIONS YIELD CORRECT +-- RESULTS FOR PREDEFINED TYPE INTEGER (INCLUDING THE CASE IN WHICH THE +-- RELATIONAL OPERATORS ARE REDEFINED). + +-- SUBTESTS ARE: +-- (A). TESTS FOR RELATIONAL OPERATORS. +-- (B). TESTS FOR MEMBERSHIP OPERATORS. +-- (C). TESTS FOR MEMBERSHIP OPERATORS IN THE CASE IN WHICH THE +-- RELATIONAL OPERATORS ARE REDEFINED. + + +-- RJW 2/4/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C45231A IS + + +BEGIN + + TEST ( "C45231A", "CHECK THAT THE RELATIONAL AND " & + "MEMBERSHIP OPERATIONS YIELD CORRECT " & + "RESULTS FOR PREDEFINED TYPE INTEGER " & + "(INCLUDING THE CASE IN WHICH THE " & + "RELATIONAL OPERATORS ARE REDEFINED)" ); + + DECLARE -- (A) + + I1A, I1B : INTEGER := IDENT_INT (1); + I2 : INTEGER := IDENT_INT (2); + CI2 : CONSTANT INTEGER := 2; + + + BEGIN -- (A) + + IF (I2 = CI2) AND (NOT (I2 /= CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 1" ); + END IF; + + IF (I2 /= 4) AND (NOT (I2 = 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 2" ); + END IF; + + IF (I1A = I1B) AND (NOT (I1A /= I1B)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 3" ); + END IF; + + IF (I2 >= CI2) AND (NOT (I2 < CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 4"); + END IF; + + IF (I2 <= 4) AND (NOT (I2 > 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 5" ); + END IF; + + IF (I1A >= I1B) AND (I1A <= I1B) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 6" ); + END IF; + + IF ">" (LEFT => CI2, RIGHT => I1A) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 7" ); + END IF; + + IF "<" (LEFT => I1A, RIGHT => I2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 8" ); + END IF; + + IF ">=" (LEFT => I1A, RIGHT => I1A ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 9 "); + END IF; + + IF "<=" (LEFT => I1A, RIGHT => CI2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 10 "); + END IF; + + IF "=" (LEFT => I1A, RIGHT => I1B ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 11 "); + END IF; + + IF "/=" (LEFT => CI2, RIGHT => 4) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 12 "); + END IF; + + END; -- (A) + + ---------------------------------------------------------------- + + DECLARE -- (B) + + SUBTYPE ST IS INTEGER RANGE -10 .. 10; + + I1 : INTEGER := IDENT_INT (1); + I5 : INTEGER := IDENT_INT (5); + + CI2 : CONSTANT INTEGER := 2; + CI10 : CONSTANT INTEGER := 10; + + + BEGIN -- (B) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.1" ); + END IF; + + IF (IDENT_INT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT_INT (-11) IN ST) + THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.5" ); + END IF; + + END; -- (B) + + ------------------------------------------------------------- + + DECLARE -- (C) + + SUBTYPE ST IS INTEGER RANGE -10 .. 10; + + I1 : INTEGER := IDENT_INT (1); + I5 : INTEGER := IDENT_INT (5); + + CI2 : CONSTANT INTEGER := 2; + CI10 : CONSTANT INTEGER := 10; + + + FUNCTION ">" ( L, R : INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN INTEGER'POS (L) <= INTEGER'POS (R); + END; + + FUNCTION ">=" ( L, R : INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN INTEGER'POS (L) < INTEGER'POS (R); + END; + + FUNCTION "<" ( L, R : INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN INTEGER'POS (L) >= INTEGER'POS (R); + END; + + FUNCTION "<=" ( L, R : INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN INTEGER'POS (L) > INTEGER'POS (R); + END; + + BEGIN -- (C) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.1" ); + END IF; + + IF (IDENT_INT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT_INT (-11) IN ST) + THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.5" ); + END IF; + + END; -- (C) + + RESULT; + +END C45231A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45231b.dep b/gcc/testsuite/ada/acats/tests/c4/c45231b.dep new file mode 100644 index 000000000..ba5fecf40 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45231b.dep @@ -0,0 +1,265 @@ +-- C45231B.DEP + +-- 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 RELATIONAL AND MEMBERSHIP OPERATIONS YIELD +-- CORRECT RESULTS FOR PREDEFINED TYPE SHORT_INTEGER (INCLUDING +-- THE CASE IN WHICH THE RELATIONAL OPERATORS ARE REDEFINED). + +-- SUBTESTS ARE: +-- (A). TESTS FOR RELATIONAL OPERATORS. +-- (B). TESTS FOR MEMBERSHIP OPERATORS. +-- (C). TESTS FOR MEMBERSHIP OPERATORS IN THE CASE IN WHICH THE +-- RELATIONAL OPERATORS ARE REDEFINED. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH +-- SUPPORT SHORT_INTEGER. + +-- IF "SHORT_INTEGER" IS NOT SUPPORTED THEN THE DECLARATION OF +-- "CHECK_SHORT" MUST BE REJECTED. + +-- HISTORY: +-- RJW 02/04/86 CREATED ORIGINAL TEST. +-- DHH 01/08/87 ENTERED APPLICABILITY CRITERIA AND FORMATTED HEADER. + +WITH REPORT; USE REPORT; + +PROCEDURE C45231B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + +BEGIN + + TEST ( "C45231B", "CHECK THAT THE RELATIONAL AND " & + "MEMBERSHIP OPERATIONS YIELD CORRECT " & + "RESULTS FOR PREDEFINED TYPE SHORT_INTEGER " & + "(INCLUDING THE CASE IN WHICH THE " & + "RELATIONAL OPERATORS ARE REDEFINED)" ); + + DECLARE -- (A) + + I1A, I1B : SHORT_INTEGER := IDENT (1); + I2 : SHORT_INTEGER := IDENT (2); + CI2 : CONSTANT SHORT_INTEGER := 2; + + + BEGIN -- (A) + + IF (I2 = CI2) AND (NOT (I2 /= CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 1" ); + END IF; + + IF (I2 /= 4) AND (NOT (I2 = 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 2" ); + END IF; + + IF (I1A = I1B) AND (NOT (I1A /= I1B)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 3" ); + END IF; + + IF (I2 >= CI2) AND (NOT (I2 < CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 4"); + END IF; + + IF (I2 <= 4) AND (NOT (I2 > 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 5" ); + END IF; + + IF (I1A >= I1B) AND (I1A <= I1B) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 6" ); + END IF; + + IF ">" (LEFT => CI2, RIGHT => I1A) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 7" ); + END IF; + + IF "<" (LEFT => I1A, RIGHT => I2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 8" ); + END IF; + + IF ">=" (LEFT => I1A, RIGHT => I1A ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 9 "); + END IF; + + IF "<=" (LEFT => I1A, RIGHT => CI2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 10 "); + END IF; + + IF "=" (LEFT => I1A, RIGHT => I1B ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 11 "); + END IF; + + IF "/=" (LEFT => CI2, RIGHT => 4) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 12 "); + END IF; + + END; -- (A) + + ---------------------------------------------------------------- + + DECLARE -- (B) + + SUBTYPE ST IS SHORT_INTEGER RANGE -10 .. 10; + + I1 : SHORT_INTEGER := IDENT (1); + I5 : SHORT_INTEGER := IDENT (5); + + CI2 : CONSTANT SHORT_INTEGER := 2; + CI10 : CONSTANT SHORT_INTEGER := 10; + + + BEGIN -- (B) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.1" ); + END IF; + + IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.5" ); + END IF; + + END; -- (B) + + ------------------------------------------------------------- + + DECLARE -- (C) + + SUBTYPE ST IS SHORT_INTEGER RANGE -10 .. 10; + + I1 : SHORT_INTEGER := IDENT (1); + I5 : SHORT_INTEGER := IDENT (5); + + CI2 : CONSTANT SHORT_INTEGER := 2; + CI10 : CONSTANT SHORT_INTEGER := 10; + + + FUNCTION ">" ( L, R : SHORT_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN SHORT_INTEGER'POS (L) <= SHORT_INTEGER'POS (R); + END; + + FUNCTION ">=" ( L, R : SHORT_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN SHORT_INTEGER'POS (L) < SHORT_INTEGER'POS (R); + END; + + FUNCTION "<" ( L, R : SHORT_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN SHORT_INTEGER'POS (L) >= SHORT_INTEGER'POS (R); + END; + + FUNCTION "<=" ( L, R : SHORT_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN SHORT_INTEGER'POS (L) > SHORT_INTEGER'POS (R); + END; + + BEGIN -- (C) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.1" ); + END IF; + + IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.5" ); + END IF; + + END; -- (C) + + RESULT; + +END C45231B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45231c.dep b/gcc/testsuite/ada/acats/tests/c4/c45231c.dep new file mode 100644 index 000000000..d2971e295 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45231c.dep @@ -0,0 +1,265 @@ +-- C45231C.DEP + +-- 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 RELATIONAL AND MEMBERSHIP OPERATIONS YIELD +-- CORRECT RESULTS FOR PREDEFINED TYPE LONG_INTEGER (INCLUDING +-- THE CASE IN WHICH THE RELATIONAL OPERATORS ARE REDEFINED). + +-- SUBTESTS ARE: +-- (A). TESTS FOR RELATIONAL OPERATORS. +-- (B). TESTS FOR MEMBERSHIP OPERATORS. +-- (C). TESTS FOR MEMBERSHIP OPERATORS IN THE CASE IN WHICH THE +-- RELATIONAL OPERATORS ARE REDEFINED. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- LONG_INTEGER. + +-- IF "LONG_INTEGER" IS NOT SUPPORTED THEN THE DECLARATION OF +-- "CHECK_LONG" MUST BE REJECTED. + +-- HISTORY: +-- RJW 02/04/86 CREATED ORIGINAL TEST. +-- DHH 01/08/87 ENTERED APPLICABILITY CRITERIA AND FORMATTED HEADER. + +WITH REPORT; USE REPORT; + +PROCEDURE C45231C IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + RETURN LONG_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + +BEGIN + + TEST ( "C45231C", "CHECK THAT THE RELATIONAL AND " & + "MEMBERSHIP OPERATIONS YIELD CORRECT " & + "RESULTS FOR PREDEFINED TYPE LONG_INTEGER " & + "(INCLUDING THE CASE IN WHICH THE " & + "RELATIONAL OPERATORS ARE REDEFINED)" ); + + DECLARE -- (A) + + I1A, I1B : LONG_INTEGER := IDENT (1); + I2 : LONG_INTEGER := IDENT (2); + CI2 : CONSTANT LONG_INTEGER := 2; + + + BEGIN -- (A) + + IF (I2 = CI2) AND (NOT (I2 /= CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 1" ); + END IF; + + IF (I2 /= 4) AND (NOT (I2 = 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 2" ); + END IF; + + IF (I1A = I1B) AND (NOT (I1A /= I1B)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 3" ); + END IF; + + IF (I2 >= CI2) AND (NOT (I2 < CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 4"); + END IF; + + IF (I2 <= 4) AND (NOT (I2 > 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 5" ); + END IF; + + IF (I1A >= I1B) AND (I1A <= I1B) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 6" ); + END IF; + + IF ">" (LEFT => CI2, RIGHT => I1A) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 7" ); + END IF; + + IF "<" (LEFT => I1A, RIGHT => I2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 8" ); + END IF; + + IF ">=" (LEFT => I1A, RIGHT => I1A ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 9 "); + END IF; + + IF "<=" (LEFT => I1A, RIGHT => CI2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 10 "); + END IF; + + IF "=" (LEFT => I1A, RIGHT => I1B ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 11 "); + END IF; + + IF "/=" (LEFT => CI2, RIGHT => 4) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 12 "); + END IF; + + END; -- (A) + + ---------------------------------------------------------------- + + DECLARE -- (B) + + SUBTYPE ST IS LONG_INTEGER RANGE -10 .. 10; + + I1 : LONG_INTEGER := IDENT (1); + I5 : LONG_INTEGER := IDENT (5); + + CI2 : CONSTANT LONG_INTEGER := 2; + CI10 : CONSTANT LONG_INTEGER := 10; + + + BEGIN -- (B) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.1" ); + END IF; + + IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.5" ); + END IF; + + END; -- (B) + + ------------------------------------------------------------- + + DECLARE -- (C) + + SUBTYPE ST IS LONG_INTEGER RANGE -10 .. 10; + + I1 : LONG_INTEGER := IDENT (1); + I5 : LONG_INTEGER := IDENT (5); + + CI2 : CONSTANT LONG_INTEGER := 2; + CI10 : CONSTANT LONG_INTEGER := 10; + + + FUNCTION ">" ( L, R : LONG_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN LONG_INTEGER'POS (L) <= LONG_INTEGER'POS (R); + END; + + FUNCTION ">=" ( L, R : LONG_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN LONG_INTEGER'POS (L) < LONG_INTEGER'POS (R); + END; + + FUNCTION "<" ( L, R : LONG_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN LONG_INTEGER'POS (L) >= LONG_INTEGER'POS (R); + END; + + FUNCTION "<=" ( L, R : LONG_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN LONG_INTEGER'POS (L) > LONG_INTEGER'POS (R); + END; + + BEGIN -- (C) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.1" ); + END IF; + + IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.5" ); + END IF; + + END; -- (C) + + RESULT; + +END C45231C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45231d.tst b/gcc/testsuite/ada/acats/tests/c4/c45231d.tst new file mode 100644 index 000000000..66be11b1b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45231d.tst @@ -0,0 +1,274 @@ +-- C45231D.TST + +-- 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 RELATIONAL AND MEMBERSHIP OPERATIONS YIELD CORRECT +-- RESULTS FOR PREDEFINED TYPE $NAME (INCLUDING THE CASE IN +-- WHICH THE RELATIONAL OPERATORS ARE REDEFINED). + +-- SUBTESTS ARE: +-- (A). TESTS FOR RELATIONAL OPERATORS. +-- (B). TESTS FOR MEMBERSHIP OPERATORS. +-- (C). TESTS FOR MEMBERSHIP OPERATORS IN THE CASE IN WHICH THE +-- RELATIONAL OPERATORS ARE REDEFINED. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT A +-- PREDEFINED INTEGER TYPE OTHER THAN INTEGER, SHORT_INTEGER, OR +-- LONG_INTEGER. + +-- IF NO SUCH PREDEFINED INTEGER TYPE IS SUPPORTED, THEN THE +-- SPECIFICATION OF THE FUNCTION IDENT MUST BE REJECTED. + +-- MACRO SUBSTITUTION: +-- $NAME IS A PREDEFINED INTEGER TYPE OTHER THAN INTEGER, +-- SHORT_INTEGER, AND LONG_INTEGER. + +-- HISTORY: +-- RJW 02/04/86 +-- THS 04/16/90 ADDED OMITTED "-- N/A => ERROR." MESSAGE AND +-- MODIFIED HEADER. + +WITH REPORT; USE REPORT; + +PROCEDURE C45231D IS + + FUNCTION IDENT (X : $NAME) + RETURN $NAME IS -- N/A => ERROR. + BEGIN + RETURN $NAME (IDENT_INT (INTEGER (X))); + END IDENT; + +BEGIN + + TEST ( "C45231D", "CHECK THAT THE RELATIONAL AND " & + "MEMBERSHIP OPERATIONS YIELD CORRECT " & + "RESULTS FOR PREDEFINED TYPE $NAME " & + "(INCLUDING THE CASE IN WHICH THE " & + "RELATIONAL OPERATORS ARE REDEFINED)" ); + + DECLARE -- (A) + + I1A, I1B : $NAME := IDENT (1); + I2 : $NAME := IDENT (2); + CI2 : CONSTANT $NAME := 2; + + + BEGIN -- (A) + + IF (I2 = CI2) AND (NOT (I2 /= CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 1" ); + END IF; + + IF (I2 /= 4) AND (NOT (I2 = 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 2" ); + END IF; + + IF (I1A = I1B) AND (NOT (I1A /= I1B)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 3" ); + END IF; + + IF (I2 >= CI2) AND (NOT (I2 < CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 4"); + END IF; + + IF (I2 <= 4) AND (NOT (I2 > 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 5" ); + END IF; + + IF (I1A >= I1B) AND (I1A <= I1B) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 6" ); + END IF; + + IF ">" (LEFT => CI2, RIGHT => I1A) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 7" ); + END IF; + + IF "<" (LEFT => I1A, RIGHT => I2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 8" ); + END IF; + + IF ">=" (LEFT => I1A, RIGHT => I1A ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 9 "); + END IF; + + IF "<=" (LEFT => I1A, RIGHT => CI2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 10 "); + END IF; + + IF "=" (LEFT => I1A, RIGHT => I1B ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 11 "); + END IF; + + IF "/=" (LEFT => CI2, RIGHT => 4) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 12 "); + END IF; + + END; -- (A) + + ---------------------------------------------------------------- + + DECLARE -- (B) + + SUBTYPE ST IS $NAME RANGE -10 .. 10; + + I1 : $NAME := IDENT (1); + I5 : $NAME := IDENT (5); + + CI2 : CONSTANT $NAME := 2; + CI10 : CONSTANT $NAME := 10; + + + BEGIN -- (B) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.1" ); + END IF; + + IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.5" ); + END IF; + + END; -- (B) + + ------------------------------------------------------------- + + DECLARE -- (C) + + SUBTYPE ST IS $NAME RANGE -10 .. 10; + + I1 : $NAME := IDENT (1); + I5 : $NAME := IDENT (5); + + CI2 : CONSTANT $NAME := 2; + CI10 : CONSTANT $NAME := 10; + + + FUNCTION ">" ( L, R : $NAME ) RETURN BOOLEAN IS + BEGIN + RETURN $NAME'POS (L) <= + $NAME'POS (R); + END; + + FUNCTION ">=" ( L, R : $NAME ) RETURN BOOLEAN IS + BEGIN + RETURN $NAME'POS (L) < + $NAME'POS (R); + END; + + FUNCTION "<" ( L, R : $NAME ) RETURN BOOLEAN IS + BEGIN + RETURN $NAME'POS (L) >= + $NAME'POS (R); + END; + + FUNCTION "<=" ( L, R : $NAME ) RETURN BOOLEAN IS + BEGIN + RETURN $NAME'POS (L) > + $NAME'POS (R); + END; + + BEGIN -- (C) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.1" ); + END IF; + + IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.5" ); + END IF; + + END; -- (C) + + RESULT; + +END C45231D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45232b.ada b/gcc/testsuite/ada/acats/tests/c4/c45232b.ada new file mode 100644 index 000000000..459bc835b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45232b.ada @@ -0,0 +1,135 @@ +-- C45232B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT NO EXCEPTION IS RAISED WHEN AN INTEGER LITERAL IN +-- A COMPARISON BELONGS TO THE BASE TYPE BUT IS OUTSIDE THE +-- SUBTYPE OF THE OTHER OPERAND. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- P. BRASHEAR 08/21/86 +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT, SYSTEM; USE REPORT; +PROCEDURE C45232B IS + +BEGIN + + TEST ("C45232B", "NO EXCEPTION IS RAISED WHEN AN INTEGER " & + "LITERAL IN A COMPARISON BELONGS TO THE BASE " & + "TYPE BUT IS OUTSIDE THE SUBTYPE OF THE " & + "OTHER OPERAND"); + + DECLARE + + TYPE INT10 IS RANGE -10 .. 5; + + BEGIN + + IF 7 > INT10'(-10) THEN + COMMENT ("NO EXCEPTION RAISED FOR '7 > " & + "INT10'(-10)'"); + ELSE + FAILED ("WRONG RESULT FOR '7 > INT10'(-10)'"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR '7 " & + "> INT10'(-10)'"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR '7 > " & + "INT10'(-10)'"); + END; + + DECLARE + + TYPE INT10 IS RANGE -10 .. 5; + + BEGIN + + IF 7 NOT IN INT10 THEN + COMMENT ("NO EXCEPTION RAISED FOR '7 NOT IN " & + "INT'"); + ELSE + FAILED ("WRONG RESULT FOR '7 NOT IN INT'"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR '7 " & + "NOT IN INT'"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR '7 NOT IN " & + "INT'"); + END; + + DECLARE + + TYPE INT700 IS RANGE -700 .. 500; + + BEGIN + IF 600 > INT700'(5) THEN + COMMENT ("NO EXCEPTION RAISED FOR '600 > " & + "INT700'(5)'"); + ELSE + FAILED ("WRONG RESULT FOR '600 > INT700'(5)'"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR '600 " & + "> INT700'(5)'"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR '600 > " & + "INT700'(5)'"); + END; + + DECLARE + + TYPE INT700 IS RANGE -700 .. 500; + + BEGIN + + IF 600 NOT IN INT700 THEN + COMMENT ("NO EXCEPTION RAISED FOR '600 NOT IN " & + "INT700'"); + ELSE + FAILED ("WRONG RESULT FOR '600 NOT IN INT700'"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR '600 " & + "NOT IN INT700'"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR '600 NOT IN " & + "INT700'"); + END; + + RESULT; + +END C45232B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45242b.ada b/gcc/testsuite/ada/acats/tests/c4/c45242b.ada new file mode 100644 index 000000000..bd05afc3b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45242b.ada @@ -0,0 +1,148 @@ +-- C45242B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT NO EXCEPTION IS RAISED WHEN A FLOATING POINT LITERAL +-- OPERAND IN A COMPARISON OR A FLOATING POINT LITERAL LEFT OPERAND +-- IN A MEMBERSHIP TEST BELONGS TO THE BASE TYPE BUT IS OUTSIDE +-- THE RANGE OF THE SUBTYPE. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- HISTORY: +-- PWB 09/04/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT, SYSTEM; USE REPORT; +PROCEDURE C45242B IS + +BEGIN + + TEST ("C45242B", "NO EXCEPTION IS RAISED WHEN A FLOATING " & + "LITERAL USED IN A COMPARISON OR AS THE " & + "LEFT OPERAND IN A MEMBERSHIP TEST " & + "BELONGS TO THE BASE TYPE BUT IS OUTSIDE " & + "THE RANGE OF THE SUBTYPE"); + + DECLARE + N : FLOAT := FLOAT (IDENT_INT (1)); + SUBTYPE FLOAT_1 IS FLOAT RANGE -1.0 .. N; + NUM : FLOAT_1 := N; + BEGIN -- PRE-DEFINED FLOAT COMPARISON + + IF EQUAL(3,3) THEN + NUM := FLOAT_1'(0.5); + END IF; + + IF 2.0 > NUM THEN + COMMENT ("NO EXCEPTION RAISED FOR PRE-DEFINED FLOAT " & + "COMPARISON"); + ELSE + FAILED ("WRONG RESULT FROM PRE-DEFINED FLOAT " & + "COMPARISON"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR PRE-DEFINED " & + "FLOAT COMPARISON"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR PRE-DEFINED " & + "FLOAT COMPARISON"); + END; -- PRE-DEFINED FLOAT COMPARISON + + DECLARE + N : FLOAT := FLOAT (IDENT_INT (1)); + SUBTYPE FLOAT_1 IS FLOAT RANGE -1.0 .. N; + BEGIN -- PRE-DEFINED FLOAT MEMBERSHIP + + IF 2.0 IN FLOAT_1 THEN + FAILED ("WRONG RESULT FROM PRE-DEFINED FLOAT " & + "MEMBERSHIP"); + ELSE + COMMENT ("NO EXCEPTION RAISED FOR PRE-DEFINED FLOAT " & + "MEMBERSHIP"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR PRE-DEFINED " & + "FLOAT MEMBERSHIP"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR PRE-DEFINED " & + "FLOAT MEMBERSHIP"); + END; -- PRE-DEFINED FLOAT MEMBERSHIP + + DECLARE -- PRECISE FLOAT COMPARISON + TYPE FINE_FLOAT IS DIGITS SYSTEM.MAX_DIGITS; + N : FINE_FLOAT := 0.5 * FINE_FLOAT (IDENT_INT (1)); + SUBTYPE SUB_FINE IS FINE_FLOAT RANGE -0.5 .. N; + NUM : SUB_FINE := N; + BEGIN + IF EQUAL(3,3) THEN + NUM := 0.25; + END IF; + + IF 0.75 > NUM THEN + COMMENT ("NO EXCEPTION RAISED FOR FINE_FLOAT " & + "COMPARISON"); + ELSE + FAILED ("WRONG RESULT FROM FINE_FLOAT COMPARISON"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR " & + "FINE_FLOAT COMPARISON"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "FINE_FLOAT COMPARISON"); + END; -- FINE_FLOAT COMPARISON + + DECLARE -- PRECISE FLOAT MEMBERSHIP + TYPE FINE_FLOAT IS DIGITS SYSTEM.MAX_DIGITS; + N : FINE_FLOAT := 0.5 * FINE_FLOAT (IDENT_INT (1)); + SUBTYPE SUB_FINE IS FINE_FLOAT RANGE -0.5 .. N; + BEGIN + + IF 0.75 IN SUB_FINE THEN + FAILED ("WRONG RESULT FROM FINE_FLOAT MEMBERSHIP"); + ELSE + COMMENT ("NO EXCEPTION RAISED FOR FINE_FLOAT " & + "MEMBERSHIP"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR " & + "FINE_FLOAT MEMBERSHIP"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "FINE_FLOAT MEMBERSHIP"); + END; -- FINE_FLOAT MEMBERSHIP + + RESULT; + +END C45242B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45251a.ada b/gcc/testsuite/ada/acats/tests/c4/c45251a.ada new file mode 100644 index 000000000..0e1bbb508 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45251a.ada @@ -0,0 +1,178 @@ +-- C45251A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR RELATIONAL OPERATIONS ON FIXED POINT TYPES THE +-- FOLLOWING HOLD: +-- (A) A /= B IS THE SAME AS NOT (A = B). +-- (B) A < B IS THE SAME AS NOT (A >= B). +-- (C) A > B IS THE SAME AS NOT (A <= B). +-- (D) ADJACENT MODEL NUMBERS GIVE CORRECT RESULTS. +-- (E) NON-MODEL NUMBERS WITH DISTINCT MODEL INTERVALS GIVE +-- CORRECT RESULTS. +-- (F) CASE WHERE MODEL INTERVALS INTERSECT IN A SINGLE MODEL +-- NUMBER GIVES CORRECT RESULT. + +-- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE. + +-- WRG 8/26/86 + +WITH REPORT; USE REPORT; +PROCEDURE C45251A IS + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0; + +BEGIN + + TEST ("C45251A", "CHECK RELATIONAL OPERATIONS FOR FIXED POINT " & + "TYPES - BASIC TYPES"); + + ------------------------------------------------------------------- + + DECLARE + A, B : LIKE_DURATION_M23 := 0.0; + C, D : DECIMAL_M4 := 0.0; + BEGIN + IF EQUAL (3, 3) THEN + A := 2#0.0000_0011#; -- JUST BELOW LIKE_DURATION'SMALL. + B := 2#0.0000_0101#; -- JUST ABOVE LIKE_DURATION'SMALL. + END IF; + + -- (A) + IF A /= B XOR NOT (A = B) THEN + FAILED ("A /= B IS NOT THE SAME AS NOT (A = B)"); + END IF; + + -- (B) + IF A < B XOR NOT (A >= B) THEN + FAILED ("A < B IS NOT THE SAME AS NOT (A >= B)"); + END IF; + + -- (C) + IF A > B XOR NOT (A <= B) THEN + FAILED ("A > B IS NOT THE SAME AS NOT (A <= B)"); + END IF; + + -- (D) + IF EQUAL (3, 3) THEN + A := -(16#1_5180.00#); -- (-86_400.0) + B := -(16#1_517F.FC#); -- (-86_400.0 + 1.0/64) + + C := 64.0; -- DECIMAL_M4'SMALL. + D := 128.0; -- 2 * DECIMAL_M4'SMALL. + END IF; + IF "=" (LEFT => A, RIGHT => B) THEN + FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " & + "- (A = B)"); + END IF; + IF NOT "/=" (LEFT => C, RIGHT => D) THEN + FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " & + "- (C /= D)"); + END IF; + IF "<" (LEFT => B, RIGHT => A) THEN + FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " & + "- (B < A)"); + END IF; + IF ">" (LEFT => C, RIGHT => D) THEN + FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " & + "- (C > D)"); + END IF; + IF ">=" (LEFT => A, RIGHT => B) THEN + FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " & + "- (A >= B)"); + END IF; + IF "<=" (LEFT => D, RIGHT => C) THEN + FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " & + "- (D <= C)"); + END IF; + + -- (E) + IF EQUAL (3, 3) THEN + A := 0.02; -- INTERVAL IS 1.0/64 .. 2.0/64. + B := -0.02; -- INTERVAL IS -2.0/64 .. -1.0/64. + + C := 800.0; -- INTERVAL IS 768.0 .. 832.0. + D := 900.0; -- INTERVAL IS 896.0 .. 960.0. + END IF; + IF A = B THEN + FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " & + "INTERVALS GIVE INCORRECT RESULT - (A = B)"); + END IF; + IF NOT (C /= D) THEN + FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " & + "INTERVALS GIVE INCORRECT RESULT - (C /= D)"); + END IF; + IF A < B THEN + FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " & + "INTERVALS GIVE INCORRECT RESULT - (A < B)"); + END IF; + IF C > D THEN + FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " & + "INTERVALS GIVE INCORRECT RESULT - (C > D)"); + END IF; + IF B >= A THEN + FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " & + "INTERVALS GIVE INCORRECT RESULT - (B >= A)"); + END IF; + IF D <= C THEN + FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " & + "INTERVALS GIVE INCORRECT RESULT - (D <= C)"); + END IF; + + -- (F) + IF EQUAL (3, 3) THEN + B := 0.035; -- INTERVAL IS 2.0/64 .. 3.0/64. + + C := 850.0; -- INTERVAL IS 832.0 .. 896.0. + END IF; + IF NOT (A <= B) THEN + FAILED ("COMPARISON OF NON-MODEL NUMBERS WITH ONE " & + "COMMON MODEL INTERVAL END-POINT GIVES " & + "INCORRECT RESULT - (A <= B)"); + END IF; + IF A > B THEN + FAILED ("COMPARISON OF NON-MODEL NUMBERS WITH ONE " & + "COMMON MODEL INTERVAL END-POINT GIVES " & + "INCORRECT RESULT - (A > B)"); + END IF; + IF NOT (D >= C) THEN + FAILED ("COMPARISON OF NON-MODEL NUMBERS WITH ONE " & + "COMMON MODEL INTERVAL END-POINT GIVES " & + "INCORRECT RESULT - (D >= C)"); + END IF; + IF D < C THEN + FAILED ("COMPARISON OF NON-MODEL NUMBERS WITH ONE " & + "COMMON MODEL INTERVAL END-POINT GIVES " & + "INCORRECT RESULT - (D < C)"); + END IF; + END; + + ------------------------------------------------------------------- + + RESULT; + +END C45251A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45252a.ada b/gcc/testsuite/ada/acats/tests/c4/c45252a.ada new file mode 100644 index 000000000..e21496662 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45252a.ada @@ -0,0 +1,200 @@ +-- C45252A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR FIXED POINT TYPES, CHECK THAT +-- CONSTRAINT_ERROR IS RAISED WHEN A LITERAL USED IN A COMPARISON OR +-- MEMBERSHIP OPERATION (AS THE FIRST OPERAND) DOES NOT BELONG TO THE +-- BASE TYPE. +-- +-- CHECK THAT NO EXCEPTION IS RAISED FOR A FIXED POINT RELATIONAL OR +-- MEMBERSHIP OPERATION IF LITERAL VALUES BELONG TO THE BASE TYPE. + +-- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- WRG 9/10/86 +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45252A IS + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE MIDDLE_M3 IS DELTA 0.5 RANGE 0.0 .. 2.5; + TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + +BEGIN + + TEST ("C45252A", "CHECK RAISING OF EXCEPTIONS BY RELATIONAL " & + "OPERATIONS FOR FIXED POINT TYPES - BASIC TYPES"); + + ------------------------------------------------------------------- + + BEGIN + -- 2.0 ** 31 < 2.9E9 < 2.0 ** 32. + IF 2.9E9 <= LIKE_DURATION_M23'LAST THEN + FAILED ("2.9E9 <= LIKE_DURATION_M23'LAST"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED BY COMPARISON " & + """2.9E9 <= LIKE_DURATION_M23'LAST"""); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY COMPARISON " & + """2.9E9 <= LIKE_DURATION_M23'LAST"""); + END; + + ------------------------------------------------------------------- + + BEGIN + -- 2.0 ** 63 < 1.0E19 < 2.0 ** 64. + IF 1.0E19 IN LIKE_DURATION_M23 THEN + FAILED ("1.0E19 IN LIKE_DURATION_M23"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " & + """1.0E19 IN LIKE_DURATION_M23"""); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY MEMBERSHIP TEST " & + """1.0E19 IN LIKE_DURATION_M23"""); + END; + + ------------------------------------------------------------------- + + BEGIN + -- 2.0 ** 63 < 1.0E19 < 2.0 ** 64. + IF 1.0E19 <= MIDDLE_M3'LAST THEN + FAILED ("1.0E19 <= MIDDLE_M3'LAST"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED BY COMPARISON " & + """1.0E19 <= MIDDLE_M3'LAST"""); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY COMPARISON " & + """1.0E19 <= MIDDLE_M3'LAST"""); + END; + + ------------------------------------------------------------------- + + BEGIN + -- 2.0 ** 31 < 2.9E9 < 2.0 ** 32. + IF 2.9E9 IN MIDDLE_M3 THEN + FAILED ("2.9E9 IN MIDDLE_M3"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " & + """2.9E9 IN MIDDLE_M3"""); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY MEMBERSHIP TEST " & + """2.9E9 IN MIDDLE_M3"""); + END; + + ------------------------------------------------------------------- + + BEGIN + -- 3.5 IS A MODEL NUMBER OF THE TYPE MIDDLE_M3. + IF 3.5 <= MIDDLE_M3'LAST THEN + FAILED ("3.5 <= MIDDLE_M3'LAST"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED BY COMPARISON " & + """3.5 <= MIDDLE_M3'LAST"""); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED BY COMPARISON " & + """3.5 <= MIDDLE_M3'LAST"""); + END; + + ------------------------------------------------------------------- + + BEGIN + IF 3.0 IN MIDDLE_M3 THEN + FAILED ("3.0 IN MIDDLE_M3"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " & + """3.0 IN MIDDLE_M3"""); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED BY MEMBERSHIP TEST " & + """3.0 IN MIDDLE_M3"""); + END; + + ------------------------------------------------------------------- + + BEGIN + IF 86_450.0 <= LIKE_DURATION_M23'LAST THEN + FAILED ("86_450.0 <= LIKE_DURATION_M23'LAST"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED BY COMPARISON " & + """86_450.0 <= LIKE_DURATION_M23'LAST"""); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED BY COMPARISON " & + """86_450.0 <= LIKE_DURATION_M23'LAST"""); + END; + + ------------------------------------------------------------------- + + BEGIN + IF 86_500.0 IN LIKE_DURATION_M23 THEN + FAILED ("86_500.0 IN LIKE_DURATION_M23"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " & + """86_500.0 IN LIKE_DURATION_M23"""); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED BY MEMBERSHIP TEST " & + """86_500.0 IN LIKE_DURATION_M23"""); + END; + + ------------------------------------------------------------------- + + BEGIN + IF -86_450.0 IN LIKE_DURATION_M23 THEN + FAILED ("-86_450.0 IN LIKE_DURATION_M23"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " & + """-86_450.0 IN LIKE_DURATION_M23"""); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED BY MEMBERSHIP TEST " & + """-86_450.0 IN LIKE_DURATION_M23"""); + END; + + ------------------------------------------------------------------- + + RESULT; + +END C45252A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45252b.ada b/gcc/testsuite/ada/acats/tests/c4/c45252b.ada new file mode 100644 index 000000000..bc6b46d38 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45252b.ada @@ -0,0 +1,146 @@ +-- C45252B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT NO EXCEPTION IS RAISED WHEN A FIXED POINT LITERAL +-- OPERAND IN A COMPARISON OR A FIXED POINT LITERAL LEFT OPERAND +-- IN A MEMBERSHIP TEST BELONGS TO THE BASE TYPE BUT IS OUTSIDE +-- THE RANGE OF THE SUBTYPE. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- HISTORY: +-- PWB 09/04/86 CREATED ORIGINAL TEST. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT, SYSTEM; USE REPORT; +PROCEDURE C45252B IS + +BEGIN + + TEST ("C45252B", "NO EXCEPTION IS RAISED WHEN A FIXED " & + "LITERAL USED IN A COMPARISON OR AS THE " & + "LEFT OPERAND IN A MEMBERSHIP TEST " & + "BELONGS TO THE BASE TYPE BUT IS OUTSIDE " & + "THE RANGE OF THE SUBTYPE"); + + DECLARE + TYPE FIXED IS DELTA 0.25 RANGE -10.0 .. 10.0; + SUBTYPE FIXED_1 IS FIXED RANGE -1.0 .. 1.0; + NUM : FIXED_1 := 0.0; + BEGIN -- FIXED COMPARISON + + IF EQUAL(3,3) THEN + NUM := FIXED_1'(0.5); + END IF; + + IF 2.0 > NUM THEN + COMMENT ("NO EXCEPTION RAISED FOR FIXED " & + "COMPARISON"); + ELSE + FAILED ("WRONG RESULT FROM FIXED " & + "COMPARISON"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR " & + "FIXED COMPARISON"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "FIXED COMPARISON"); + END; -- FIXED COMPARISON + + DECLARE + TYPE FIXED IS DELTA 0.25 RANGE -10.0 .. 10.0; + SUBTYPE FIXED_1 IS FIXED RANGE -1.0 .. 1.0; + BEGIN -- FIXED MEMBERSHIP + + IF 2.0 IN FIXED_1 THEN + FAILED ("WRONG RESULT FROM FIXED " & + "MEMBERSHIP"); + ELSE + COMMENT ("NO EXCEPTION RAISED FOR FIXED " & + "MEMBERSHIP"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR " & + "FIXED MEMBERSHIP"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "FIXED MEMBERSHIP"); + END; -- FIXED MEMBERSHIP + + DECLARE -- PRECISE FIXED COMPARISON + TYPE FINE_FIXED IS DELTA SYSTEM.FINE_DELTA RANGE -1.0 .. 1.0; + SUBTYPE SUB_FINE IS FINE_FIXED RANGE -0.5 .. 0.5; + NUM : SUB_FINE := 0.0; + BEGIN + IF EQUAL(3,3) THEN + NUM := 0.25; + END IF; + + IF 0.75 > NUM THEN + COMMENT ("NO EXCEPTION RAISED FOR FINE_FIXED " & + "COMPARISON"); + ELSE + FAILED ("WRONG RESULT FROM FINE_FIXED COMPARISON"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR " & + "FINE_FIXED COMPARISON"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "FINE_FIXED COMPARISON"); + END; -- FINE_FIXED COMPARISON + + DECLARE -- PRECISE FIXED MEMBERSHIP + TYPE FINE_FIXED IS DIGITS SYSTEM.MAX_DIGITS; + SUBTYPE SUB_FINE IS FINE_FIXED RANGE -0.5 .. 0.5; + BEGIN + + IF 0.75 IN SUB_FINE THEN + FAILED ("WRONG RESULT FROM FINE_FIXED MEMBERSHIP"); + ELSE + COMMENT ("NO EXCEPTION RAISED FOR FINE_FIXED " & + "MEMBERSHIP"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR " & + "FINE_FIXED MEMBERSHIP"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "FINE_FIXED MEMBERSHIP"); + END; -- FINE_FIXED MEMBERSHIP + + RESULT; + +END C45252B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45253a.ada b/gcc/testsuite/ada/acats/tests/c4/c45253a.ada new file mode 100644 index 000000000..d2a06618a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45253a.ada @@ -0,0 +1,97 @@ +-- C45253A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR FIXED POINT TYPES "A IN T" AND "A NOT IN T" GIVE +-- APPROPRIATE RESULTS, EVEN WHEN USER-DEFINED ORDERING OPERATORS EXIST +-- FOR T. + +-- WRG 8/27/86 +-- JRL 06/12/96 Added function The_Delta. Eliminated static expressions +-- outside the base range of type T. + +WITH REPORT; USE REPORT; +PROCEDURE C45253A IS + + TYPE FIXED IS DELTA 0.25 RANGE 0.0 .. 1000.0; + TYPE T IS NEW FIXED; + + FUNCTION "<" (LEFT, RIGHT : T) RETURN BOOLEAN IS + BEGIN + RETURN FIXED (LEFT) >= FIXED (RIGHT); + END "<"; + + FUNCTION "<=" (LEFT, RIGHT : T) RETURN BOOLEAN IS + BEGIN + RETURN FIXED (LEFT) > FIXED (RIGHT); + END "<="; + + FUNCTION ">" (LEFT, RIGHT : T) RETURN BOOLEAN IS + BEGIN + RETURN FIXED (LEFT) <= FIXED (RIGHT); + END ">"; + + FUNCTION ">=" (LEFT, RIGHT : T) RETURN BOOLEAN IS + BEGIN + RETURN FIXED (LEFT) < FIXED (RIGHT); + END ">="; + + function The_Delta return T is + begin + return T'Delta; + end The_Delta; + +BEGIN + + TEST ("C45253A", "CHECK THAT FOR FIXED POINT TYPES ""A IN T"" " & + "AND ""A NOT IN T"" GIVE APPROPRIATE RESULTS, " & + "EVEN WHEN USER-DEFINED ORDERING OPERATORS " & + "EXIST FOR T"); + + IF IDENT_INT (1) * 0.0 NOT IN T THEN + FAILED ("0.0 NOT IN T"); + END IF; + +-- 06/12/96 IF IDENT_INT (1) * 1000.0 NOT IN T THEN + if Ident_Int (2) * 500.0 not in T then + FAILED ("1000.0 NOT IN T"); + END IF; + +-- 06/12/96 IF IDENT_INT (1) * (-0.25) IN T THEN + if Ident_Int (1) * (-The_Delta) in T then + FAILED ("-0.25 IN T"); + END IF; + +-- 06/12/96 IF IDENT_INT (1) * 1000.25 IN T THEN + if Ident_Int (2) * 500.0 + The_Delta in T then + FAILED ("1000.25 IN T"); + END IF; + +-- 06/12/96 IF IDENT_INT (1) * (-1000.0) IN T THEN + if Ident_Int (2) * (-500.0) in T then + FAILED ("-1000.0 IN T"); + END IF; + + RESULT; + +END C45253A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45262a.ada b/gcc/testsuite/ada/acats/tests/c4/c45262a.ada new file mode 100644 index 000000000..270dc88dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45262a.ada @@ -0,0 +1,214 @@ +-- C45262A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ORDERING COMPARISONS YIELD CORRECT RESULTS FOR +-- ONE-DIMENSIONAL DISCRETE ARRAY TYPES. THIS TEST CHECKS ARRAYS OF +-- INTEGERS. + +-- JWC 8/19/85 +-- JRK 6/24/86 FIXED SPELLING IN FAILURE MESSAGE. + +WITH REPORT; USE REPORT; + +PROCEDURE C45262A IS +BEGIN + TEST ("C45262A", "ORDERING COMPARISONS OF ONE-DIMENSIONAL " & + "DISCRETE ARRAY TYPES - INTEGER COMPONENTS"); + + DECLARE + + TYPE ARR IS ARRAY( INTEGER RANGE <> ) OF INTEGER; + ARR1 : ARR(1 .. IDENT_INT(0)); + ARR2 : ARR(2 .. IDENT_INT(0)); + ARR3 : ARR(1 .. IDENT_INT(1)) := (IDENT_INT(1) => 0); + ARR4 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => 0); + ARR5 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => 1); + ARR6 : ARR(1 .. IDENT_INT(5)) := (1 .. IDENT_INT(5) => 0); + ARR7 : ARR(0 .. 4) := (0 .. 3 => 0, 4 => 1); + ARR8 : ARR(0 .. IDENT_INT(4)) := (0 .. IDENT_INT(4) => 0); + ARR9 : ARR(0 .. IDENT_INT(3)) := (0 .. IDENT_INT(3) => 0); + ARRA : ARR(0 .. IDENT_INT(3)) := (0 .. IDENT_INT(3) => 1); + + BEGIN + IF ARR1 < ARR2 THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <"); + END IF; + + IF NOT (ARR1 <= ARR2) THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <="); + END IF; + + IF ARR1 > ARR2 THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - >"); + END IF; + + IF NOT ( ">=" (ARR1, ARR2) ) THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - >="); + END IF; + + IF ARR3 < ARR1 THEN + FAILED ("NON-NULL ARRAY ARR3 LESS THAN NULL ARR1"); + END IF; + + IF ARR3 <= ARR1 THEN + FAILED ("NON-NULL ARRAY ARR3 LESS THAN EQUAL NULL ARR1"); + END IF; + + IF NOT ( ">" (ARR3, ARR1) ) THEN + FAILED ("NON-NULL ARRAY ARR3 NOT GREATER THAN NULL " & + "ARR1"); + END IF; + + IF NOT (ARR3 >= ARR1) THEN + FAILED ("NON-NULL ARRAY ARR3 NOT GREATER THAN EQUAL " & + "NULL ARR1"); + END IF; + + IF ARR3 < ARR4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <"); + END IF; + + IF NOT ( "<=" (ARR3, ARR4) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <="); + END IF; + + IF ARR3 > ARR4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR3 >= ARR4) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >="); + END IF; + + IF NOT ( "<" (ARR3, ARR5) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (ARR3 <= ARR5) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <="); + END IF; + + IF ARR3 > ARR5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >"); + END IF; + + IF ARR3 >= ARR5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + IF NOT (ARR6 < ARR7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (ARR6 <= ARR7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " & + "<="); + END IF; + + IF ARR6 > ARR7 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - >"); + END IF; + + IF ">=" (LEFT => ARR6, RIGHT => ARR7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " & + ">="); + END IF; + + IF ARR6 < ARR8 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <"); + END IF; + + IF NOT (ARR6 <= ARR8) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <="); + END IF; + + IF ">" (RIGHT => ARR8, LEFT => ARR6) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR6 >= ARR8) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >="); + END IF; + + IF ARR8 < ARR9 THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <"); + END IF; + + IF ARR8 <= ARR9 THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <="); + END IF; + + IF NOT (ARR8 > ARR9) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR8 >= ARR9) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >="); + END IF; + + IF NOT (ARR8 < ARRA) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (ARR8 <= ARRA) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <="); + END IF; + + IF ARR8 > ARRA THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >"); + END IF; + + IF ARR8 >= ARRA THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + END; + + RESULT; + +END C45262A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45262b.ada b/gcc/testsuite/ada/acats/tests/c4/c45262b.ada new file mode 100644 index 000000000..9d4e80676 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45262b.ada @@ -0,0 +1,219 @@ +-- C45262B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ORDERING COMPARISONS YIELD CORRECT RESULTS FOR +-- ONE-DIMENSIONAL DISCRETE ARRAY TYPES. THIS TEST CHECKS STRING TYPES. + +-- JWC 9/9/85 +-- JRK 6/24/86 FIXED SPELLING IN FAILURE MESSAGE. + +WITH REPORT; USE REPORT; + +PROCEDURE C45262B IS +BEGIN + TEST ("C45262B", "ORDERING COMPARISONS OF ONE-DIMENSIONAL " & + "DISCRETE ARRAY TYPES - TYPE STRING"); + + DECLARE + + STRING1 : STRING(2 .. IDENT_INT(1)); + STRING2 : STRING(3 .. IDENT_INT(1)); + STRING3 : STRING(2 .. IDENT_INT(2)) := (IDENT_INT(2) => 'A'); + STRING4 : STRING(1 .. IDENT_INT(1)) := (IDENT_INT(1) => 'A'); + STRING5 : STRING(1 .. IDENT_INT(1)) := (IDENT_INT(1) => 'B'); + STRING6 : STRING(2 .. IDENT_INT(6)) := + (2 .. IDENT_INT(6) => 'A'); + STRING7 : STRING(1 .. 5) := (1 .. 4 => 'A', 5 => 'B'); + STRING8 : STRING(1 .. IDENT_INT(5)) := + (1 .. IDENT_INT(5) => 'A'); + STRING9 : STRING(1 .. IDENT_INT(4)) := + (1 .. IDENT_INT(4) => 'A'); + STRINGA : STRING(1 .. IDENT_INT(4)) := + (1 .. IDENT_INT(4) => 'B'); + + BEGIN + IF STRING1 < STRING2 THEN + FAILED ("NULL ARRAYS STRING1 AND STRING2 NOT EQUAL - <"); + END IF; + + IF NOT (STRING1 <= STRING2) THEN + FAILED ("NULL ARRAYS STRING1 AND STRING2 NOT EQUAL - " & + "<="); + END IF; + + IF STRING1 > STRING2 THEN + FAILED ("NULL ARRAYS STRING1 AND STRING2 NOT EQUAL - >"); + END IF; + + IF NOT ( ">=" (STRING1, STRING2) ) THEN + FAILED ("NULL ARRAYS STRING1 AND STRING2 NOT EQUAL - " & + ">="); + END IF; + + IF STRING3 < STRING1 THEN + FAILED ("NON-NULL ARRAY STRING3 LESS THAN NULL STRING1"); + END IF; + + IF STRING3 <= STRING1 THEN + FAILED ("NON-NULL ARRAY STRING3 LESS THAN EQUAL NULL " & + "STRING1"); + END IF; + + IF NOT ( ">" (STRING3, STRING1) ) THEN + FAILED ("NON-NULL ARRAY STRING3 NOT GREATER THAN NULL " & + "STRING1"); + END IF; + + IF NOT (STRING3 >= STRING1) THEN + FAILED ("NON-NULL ARRAY STRING3 NOT GREATER THAN " & + "EQUAL NULL STRING1"); + END IF; + + IF STRING3 < STRING4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <"); + END IF; + + IF NOT ( "<=" (STRING3, STRING4) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <="); + END IF; + + IF STRING3 > STRING4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (STRING3 >= STRING4) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >="); + END IF; + + IF NOT ( "<" (STRING3, STRING5) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (STRING3 <= STRING5) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <="); + END IF; + + IF STRING3 > STRING5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >"); + END IF; + + IF STRING3 >= STRING5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + IF NOT (STRING6 < STRING7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (STRING6 <= STRING7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " & + "<="); + END IF; + + IF STRING6 > STRING7 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - >"); + END IF; + + IF ">=" (LEFT => STRING6, RIGHT => STRING7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " & + ">="); + END IF; + + IF STRING6 < STRING8 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <"); + END IF; + + IF NOT (STRING6 <= STRING8) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <="); + END IF; + + IF ">" (RIGHT => STRING8, LEFT => STRING6) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >"); + END IF; + + IF NOT (STRING6 >= STRING8) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >="); + END IF; + + IF STRING8 < STRING9 THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <"); + END IF; + + IF STRING8 <= STRING9 THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <="); + END IF; + + IF NOT (STRING8 > STRING9) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (STRING8 >= STRING9) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >="); + END IF; + + IF NOT (STRING8 < STRINGA) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (STRING8 <= STRINGA) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <="); + END IF; + + IF STRING8 > STRINGA THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >"); + END IF; + + IF STRING8 >= STRINGA THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + END; + + RESULT; + +END C45262B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45262c.ada b/gcc/testsuite/ada/acats/tests/c4/c45262c.ada new file mode 100644 index 000000000..a4e156a74 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45262c.ada @@ -0,0 +1,216 @@ +-- C45262C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ORDERING COMPARISONS YIELD CORRECT RESULTS FOR +-- ONE-DIMENSIONAL DISCRETE ARRAY TYPES. THIS TEST CHECKS ARRAYS OF +-- AN ENUMERATION TYPE. + +-- JWC 8/19/85 +-- JRK 6/24/86 FIXED SPELLING IN FAILURE MESSAGE. + +WITH REPORT; USE REPORT; + +PROCEDURE C45262C IS +BEGIN + TEST ("C45262C", "ORDERING COMPARISONS OF ONE-DIMENSIONAL " & + "DISCRETE ARRAY TYPES - ENUMERATED COMPONENTS"); + + DECLARE + + SUBTYPE SUBINT IS INTEGER RANGE 0 .. 5; + TYPE ENUM IS (E0, E1); + TYPE ARR IS ARRAY( SUBINT RANGE <> ) OF ENUM; + ARR1 : ARR(1 .. IDENT_INT(0)); + ARR2 : ARR(2 .. IDENT_INT(0)); + ARR3 : ARR(1 .. IDENT_INT(1)) := (IDENT_INT(1) => E0); + ARR4 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => E0); + ARR5 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => E1); + ARR6 : ARR(1 .. IDENT_INT(5)) := (1 .. IDENT_INT(5) => E0); + ARR7 : ARR(0 .. 4) := (0 .. 3 => E0, 4 => E1); + ARR8 : ARR(0 .. IDENT_INT(4)) := (0 .. IDENT_INT(4) => E0); + ARR9 : ARR(0 .. IDENT_INT(3)) := (0 .. IDENT_INT(3) => E0); + ARRA : ARR(0 .. IDENT_INT(3)) := (0 .. IDENT_INT(3) => E1); + + BEGIN + IF ARR1 < ARR2 THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <"); + END IF; + + IF NOT (ARR1 <= ARR2) THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <="); + END IF; + + IF ARR1 > ARR2 THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - >"); + END IF; + + IF NOT ( ">=" (ARR1, ARR2) ) THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - >="); + END IF; + + IF ARR3 < ARR1 THEN + FAILED ("NON-NULL ARRAY ARR3 LESS THAN NULL ARR1"); + END IF; + + IF ARR3 <= ARR1 THEN + FAILED ("NON-NULL ARRAY ARR3 LESS THAN EQUAL NULL ARR1"); + END IF; + + IF NOT ( ">" (ARR3, ARR1) ) THEN + FAILED ("NON-NULL ARRAY ARR3 NOT GREATER THAN NULL " & + "ARR1"); + END IF; + + IF NOT (ARR3 >= ARR1) THEN + FAILED ("NON-NULL ARRAY ARR3 NOT GREATER THAN EQUAL " & + "NULL ARR1"); + END IF; + + IF ARR3 < ARR4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <"); + END IF; + + IF NOT ( "<=" (ARR3, ARR4) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <="); + END IF; + + IF ARR3 > ARR4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR3 >= ARR4) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >="); + END IF; + + IF NOT ( "<" (ARR3, ARR5) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (ARR3 <= ARR5) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <="); + END IF; + + IF ARR3 > ARR5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >"); + END IF; + + IF ARR3 >= ARR5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + IF NOT (ARR6 < ARR7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (ARR6 <= ARR7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " & + "<="); + END IF; + + IF ARR6 > ARR7 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - >"); + END IF; + + IF ">=" (LEFT => ARR6, RIGHT => ARR7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " & + ">="); + END IF; + + IF ARR6 < ARR8 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <"); + END IF; + + IF NOT (ARR6 <= ARR8) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <="); + END IF; + + IF ">" (RIGHT => ARR8, LEFT => ARR6) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR6 >= ARR8) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >="); + END IF; + + IF ARR8 < ARR9 THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <"); + END IF; + + IF ARR8 <= ARR9 THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <="); + END IF; + + IF NOT (ARR8 > ARR9) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR8 >= ARR9) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >="); + END IF; + + IF NOT (ARR8 < ARRA) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (ARR8 <= ARRA) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <="); + END IF; + + IF ARR8 > ARRA THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >"); + END IF; + + IF ARR8 >= ARRA THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + END; + + RESULT; + +END C45262C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45262d.ada b/gcc/testsuite/ada/acats/tests/c4/c45262d.ada new file mode 100644 index 000000000..7889501b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45262d.ada @@ -0,0 +1,105 @@ +-- C45262D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ORDERING COMPARISONS YIELD CORRECT RESULTS FOR +-- ONE-DIMENSIONAL DISCRETE ARRAY TYPES. THIS TEST USES +-- USER-DEFINED ORDERING OPERATORS FOR THE DISCRETE COMPONENT TYPE. + +-- JWC 8/19/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C45262D IS + + FUNCTION "<"(LEFT, RIGHT : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN STANDARD.">="(LEFT, RIGHT); + END "<"; + + FUNCTION "<="(LEFT, RIGHT : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN STANDARD.">"(LEFT, RIGHT); + END "<="; + + FUNCTION ">"(LEFT, RIGHT : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN STANDARD."<="(LEFT, RIGHT); + END ">"; + + FUNCTION ">="(LEFT, RIGHT : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN STANDARD."<"(LEFT, RIGHT); + END ">="; + +BEGIN + TEST ("C45262D", "ORDERING COMPARISONS OF ONE-DIMENSIONAL " & + "DISCRETE ARRAY TYPES"); + + DECLARE + + SUBTYPE SUBINT IS INTEGER RANGE 0 .. 5; + TYPE ARR IS ARRAY( SUBINT RANGE <> ) OF INTEGER; + ARR1 : ARR(1 .. IDENT_INT(0)); + ARR2 : ARR(2 .. IDENT_INT(0)); + ARR3 : ARR(1 .. IDENT_INT(1)) := (IDENT_INT(1) => 0); + ARR4 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => 0); + ARR5 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => 1); + ARR6 : ARR(1 .. IDENT_INT(5)) := (1 .. IDENT_INT(5) => 0); + ARR7 : ARR(0 .. 4) := (0 .. 3 => 0, 4 => 1); + + BEGIN + + IF ARR1 < ARR2 THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <"); + END IF; + + IF ARR3 <= ARR1 THEN + FAILED ("NON-NULL ARRAY ARR3 LESS THAN EQUAL NULL " & + "ARR1"); + END IF; + + IF ARR3 > ARR4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR3(1) > ARR4(0)) THEN + FAILED ("REDEFINED COMPONENT COMPARISON - >"); + END IF; + + IF ARR3 >= ARR5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + IF NOT ( "<" (ARR6, ARR7) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - <"); + END IF; + + END; + + RESULT; + +END C45262D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45264a.ada b/gcc/testsuite/ada/acats/tests/c4/c45264a.ada new file mode 100644 index 000000000..d701be0f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45264a.ada @@ -0,0 +1,109 @@ +-- C45264A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT EQUALITY COMPARISONS YIELD CORRECT RESULTS FOR ONE +-- DIMENSIONAL AND MULTI-DIMENSIONAL ARRAY TYPES. +-- CASE THAT CHECKS THAT TWO NULL ARRAYS OF THE SAME TYPE ARE +-- ALWAYS EQUAL. + +-- PK 02/21/84 +-- EG 05/30/84 + +WITH REPORT; +USE REPORT; + +PROCEDURE C45264A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + +BEGIN + + TEST("C45264A","CHECK THAT EQUALITY COMPARISONS YIELD CORRECT " & + "RESULTS FOR ONE DIMENSIONAL AND MULTI-" & + "DIMENSIONAL ARRAY TYPES"); + + DECLARE + + TYPE A1 IS ARRAY(INT RANGE <>) OF INTEGER; + + BEGIN + + IF A1'(1 .. IDENT_INT(2) => IDENT_INT(1)) /= + A1'(IDENT_INT(2) .. 3 => IDENT_INT(1)) THEN + FAILED ("A1 - ARRAYS NOT EQUAL"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("A1 - EXCEPTION RAISED"); + + END; + + DECLARE + + TYPE A2 IS ARRAY(INT RANGE <>, INT RANGE <>) OF INTEGER; + + BEGIN + IF A2'(1 .. IDENT_INT(2) => + (IDENT_INT(3) .. IDENT_INT(2) => IDENT_INT(1))) /= + A2'(IDENT_INT(2) .. 3 => + (IDENT_INT(2) .. IDENT_INT(1) => IDENT_INT(1))) THEN + FAILED ("A2 - ARRAYS NOT EQUAL"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("A2 - EXCEPTION RAISED"); + + END; + + DECLARE + + TYPE A3 IS + ARRAY(INT RANGE <>, INT RANGE <>, INT RANGE <>) OF + INTEGER; + + BEGIN + + IF A3'(1 .. IDENT_INT(2) => + (IDENT_INT(1) .. IDENT_INT(3) => + (IDENT_INT(3) .. IDENT_INT(2) => IDENT_INT(1)))) /= + A3'(IDENT_INT(1) .. 3 => + (IDENT_INT(2) .. IDENT_INT(1) => + (IDENT_INT(1) .. IDENT_INT(2) => IDENT_INT(1)))) THEN + FAILED ("A3 - ARRAYS NOT EQUAL"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("A3 - EXCEPTION RAISED"); + + END; + + RESULT; + +END C45264A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45264b.ada b/gcc/testsuite/ada/acats/tests/c4/c45264b.ada new file mode 100644 index 000000000..44063f7ac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45264b.ada @@ -0,0 +1,88 @@ +-- C45264B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT EQUALITY COMPARISONS YIELD CORRECT RESULTS FOR ONE +-- DIMENSIONAL AND MULTI-DIMENSIONAL ARRAY TYPES. +-- THIS TEST CHECKS THE CASE WHERE THE ARRAY HAS A BOUND THAT DEPENDS ON +-- A DISCRIMINANT WITH DEFAULTS. + +-- JWC 11/18/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C45264B IS + +BEGIN + + TEST("C45264B","CHECK THAT EQUALITY COMPARISONS YIELD CORRECT " & + "RESULTS FOR ONE DIMENSIONAL AND MULTI-" & + "DIMENSIONAL ARRAY TYPES"); + + DECLARE + + SUBTYPE SUBINT IS INTEGER RANGE 1 .. 5; + TYPE REC (DISC : SUBINT := 1) IS + RECORD + COMP : STRING(IDENT_INT(3) .. DISC); + END RECORD; + TYPE ARR IS ARRAY (1 .. 3) OF REC; + + A1, A2 : ARR; + + BEGIN + + IF A1 /= A2 THEN + FAILED ("NULL ARRAYS, RESULT NOT EQUAL"); + END IF; + + A1(2) := (5, "ABC"); + + IF A1 = A2 THEN + FAILED ("NON-NULL ARRAY AND NULL ARRAY, RESULT EQUAL"); + END IF; + + A2(2) := (5, "ABD"); + + IF A1 = A2 THEN + FAILED ("ARRAYS DIFFER BY LAST ELEMENT, RESULT EQUAL"); + END IF; + + A2(2) := (4, "AB"); + + IF A1 = A2 THEN + FAILED ("ARRAYS OF DIFFERENT LENGTH, RESULT EQUAL"); + END IF; + + A1(2) := (4, "AB"); + + IF A1 /= A2 THEN + FAILED ("DISCRIMINANTS AND COMPONENTS ARE THE SAME, " & + "RESULT NOT EQUAL"); + END IF; + + END; + + RESULT; + +END C45264B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45264c.ada b/gcc/testsuite/ada/acats/tests/c4/c45264c.ada new file mode 100644 index 000000000..c9959a5ba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45264c.ada @@ -0,0 +1,153 @@ +-- C45264C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT COMPARING ARRAYS OF DIFFERENT LENGTHS DOES NOT RAISE AN +-- EXCEPTION. + +-- TBN 7/21/86 + +WITH REPORT; USE REPORT; +PROCEDURE C45264C IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 10; + TYPE ARRAY_TYPE_1 IS ARRAY (INT RANGE <>) OF INTEGER; + TYPE ARRAY_TYPE_2 IS ARRAY (INT RANGE <>, INT RANGE <>) OF INTEGER; + TYPE ARRAY_TYPE_3 IS ARRAY (INT RANGE <>, INT RANGE <>, + INT RANGE <>) OF INTEGER; + + ARRAY_1 : ARRAY_TYPE_1 (1..5) := (1..5 => 1); + ARRAY_2 : ARRAY_TYPE_1 (1..7) := (1..7 => 1); + ARRAY_3 : ARRAY_TYPE_2 (1..5, 1..4) := (1..5 => (1..4 => 1)); + ARRAY_4 : ARRAY_TYPE_2 (1..2, 1..3) := (1..2 => (1..3 => 1)); + ARRAY_5 : ARRAY_TYPE_3 (1..2, 1..3, 1..2) := (1..2 => (1..3 => + (1..2 => 2))); + ARRAY_6 : ARRAY_TYPE_3 (1..1, 1..2, 1..3) := (1..1 => (1..2 => + (1..3 => 2))); + ARRAY_7 : ARRAY_TYPE_2 (1..5, 1..4) := (1..5 => (1..4 => 3)); + ARRAY_8 : ARRAY_TYPE_2 (1..5, 1..3) := (1..5 => (1..3 => 3)); + ARRAY_9 : ARRAY_TYPE_2 (1..3, 1..2) := (1..3 => (1..2 => 4)); + ARRAY_10 : ARRAY_TYPE_2 (1..2, 1..2) := (1..2 => (1..2 => 4)); + +BEGIN + TEST ("C45264C", "CHECK THAT COMPARING ARRAYS OF DIFFERENT " & + "LENGTHS DOES NOT RAISE AN EXCEPTION"); + + BEGIN -- (A) + IF "=" (ARRAY_1 (1..INTEGER'FIRST), ARRAY_2) THEN + FAILED ("INCORRECT RESULTS FROM COMPARING ONE " & + "DIMENSIONAL ARRAYS - 1"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED EVALUATING - 1"); + END; -- (A) + + BEGIN -- (B) + IF ARRAY_1 /= ARRAY_2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM COMPARING ONE " & + "DIMENSIONAL ARRAYS - 2"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED EVALUATING - 2"); + END; -- (B) + + BEGIN -- (C) + IF ARRAY_3 = ARRAY_4 THEN + FAILED ("INCORRECT RESULTS FROM COMPARING MULTI-" & + "DIMENSIONAL ARRAYS - 3"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED EVALUATING - 3"); + END; -- (C) + + BEGIN -- (D) + IF "/=" (ARRAY_3, ARRAY_4) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM COMPARING MULT-" & + "DIMENSIONAL ARRAYS - 4"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 4"); + END; -- (D) + + BEGIN -- (E) + IF "=" (ARRAY_5, ARRAY_6) THEN + FAILED ("INCORRECT RESULTS FROM COMPARING MULTI-" & + "DIMENSIONAL ARRAYS - 5"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED EVALUATING - 5"); + END; -- (E) + + BEGIN -- (F) + IF ARRAY_6 /= ARRAY_5 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM COMPARING MULT-" & + "DIMENSIONAL ARRAYS - 6"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 6"); + END; -- (F) + + BEGIN -- (G) + IF ARRAY_7 = ARRAY_8 THEN + FAILED ("INCORRECT RESULTS FROM COMPARING MULTI-" & + "DIMENSIONAL ARRAYS - 7"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED EVALUATING - 7"); + END; -- (G) + + BEGIN -- (H) + IF ARRAY_9 /= ARRAY_10 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM COMPARING MULTI-" & + "DIMENSIONAL ARRAYS - 8"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED EVALUATING - 8"); + END; -- (H) + + RESULT; +END C45264C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45265a.ada b/gcc/testsuite/ada/acats/tests/c4/c45265a.ada new file mode 100644 index 000000000..711124358 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45265a.ada @@ -0,0 +1,196 @@ +-- C45265A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT MEMBERSHIP TESTS YIELD THE CORRECT RESULTS FOR ONE +-- DIMENSIONAL AND MULTI-DIMENSIONAL ARRAY TYPES WHEN: +-- A) THE SUBTYPE INDICATION DENOTES AN UNCONSTRAINED ARRAY. +-- B) THE SUBTYPE INDICATION DENOTES A CONSTRAINED ARRAY. + +-- TBN 7/22/86 + +WITH REPORT; USE REPORT; +PROCEDURE C45265A IS + + PACKAGE P IS + TYPE KEY IS LIMITED PRIVATE; + PRIVATE + TYPE KEY IS NEW NATURAL; + END P; + + SUBTYPE INT IS INTEGER RANGE 1 .. 20; + TYPE ARRAY_TYPE_1 IS ARRAY (INT RANGE <>) OF INTEGER; + TYPE ARRAY_TYPE_2 IS ARRAY (INT RANGE <>, INT RANGE <>) OF INTEGER; + TYPE ARRAY_TYPE_3 IS ARRAY (INT RANGE <>, INT RANGE <>, + INT RANGE <>) OF INTEGER; + TYPE ARRAY_TYPE_4 IS ARRAY (INT RANGE <>) OF P.KEY; + TYPE ARRAY_TYPE_5 IS ARRAY (INT RANGE <>, INT RANGE <>) OF P.KEY; + + SUBTYPE ARRAY_SUB1 IS ARRAY_TYPE_1; + SUBTYPE ARRAY_SUB2 IS ARRAY_TYPE_2; + SUBTYPE ARRAY_SUB3 IS ARRAY_TYPE_3; + SUBTYPE ARRAY_SUB4 IS ARRAY_TYPE_4; + SUBTYPE ARRAY_SUB5 IS ARRAY_TYPE_5; + SUBTYPE CON_ARRAY1 IS ARRAY_TYPE_1 (1..5); + SUBTYPE CON_ARRAY2 IS ARRAY_TYPE_2 (1..2, 1..2); + SUBTYPE CON_ARRAY3 IS ARRAY_TYPE_3 (1..2, 1..3, 1..4); + SUBTYPE CON_ARRAY4 IS ARRAY_TYPE_4 (1..4); + SUBTYPE CON_ARRAY5 IS ARRAY_TYPE_5 (1..2, 1..3); + SUBTYPE NULL_ARRAY1 IS ARRAY_TYPE_1 (2 .. 1); + + ARRAY1 : ARRAY_TYPE_1 (1..10); + ARRAY2 : ARRAY_SUB1 (11..20); + ARRAY3 : ARRAY_TYPE_2 (1..4, 1..3); + ARRAY4 : ARRAY_SUB2 (5..7, 5..8); + ARRAY5 : ARRAY_TYPE_3 (1..2, 1..3, 1..4); + ARRAY6 : ARRAY_SUB3 (1..3, 1..2, 1..4); + NULL_ARRAY_1 : ARRAY_TYPE_1 (3..2); + NULL_ARRAY_2 : ARRAY_SUB1 (2..1); + ARRAY7 : ARRAY_TYPE_1 (1..10) := (1..10 => 7); + ARRAY8 : CON_ARRAY1 := (1..5 => 8); + ARRAY9 : ARRAY_TYPE_2 (1..10, 1..10) := (1..10 => (1..10 => 9)); + ARRAY10 : CON_ARRAY2 := (1..2 => (1..2 => 10)); + ARRAY11 : ARRAY_TYPE_3 (1..10, 1..10, 1..10) := (1..10 => + (1..10 => (1..10 => 11))); + ARRAY12 : CON_ARRAY3 := (1..2 => (1..3 => (1..4 => 12))); + ARRAY13 : ARRAY_TYPE_4 (1..2); + ARRAY14 : ARRAY_SUB4 (1..5); + ARRAY15 : ARRAY_TYPE_4 (1..6); + ARRAY16 : CON_ARRAY4; + ARRAY17 : ARRAY_TYPE_5 (1..3, 1..2); + ARRAY18 : ARRAY_SUB5 (1..2, 1..3); + ARRAY19 : ARRAY_TYPE_5 (1..4, 1..3); + ARRAY20 : CON_ARRAY5; + +BEGIN + TEST ("C45265A", "CHECK THAT MEMBERSHIP TESTS YIELD THE CORRECT " & + "RESULTS FOR ONE DIMENSIONAL AND MULTI-" & + "DIMENSIONAL ARRAY TYPES"); + + ARRAY1 := (ARRAY1'RANGE => 1); + ARRAY2 := (ARRAY2'RANGE => 2); + ARRAY3 := (ARRAY3'RANGE(1) => (ARRAY3'RANGE(2) => 3)); + ARRAY4 := (ARRAY4'RANGE(1) => (ARRAY4'RANGE(2) => 4)); + ARRAY5 := (ARRAY5'RANGE(1) => (ARRAY5'RANGE(2) => + (ARRAY5'RANGE(3) => 5))); + ARRAY6 := (ARRAY6'RANGE(1) => (ARRAY6'RANGE(2) => + (ARRAY6'RANGE(3) => 6))); + + IF ARRAY1 IN ARRAY_SUB1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 1"); + END IF; + IF ARRAY2 NOT IN ARRAY_SUB1 THEN + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 2"); + END IF; + + IF ARRAY3 IN ARRAY_SUB2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 3"); + END IF; + IF ARRAY4 NOT IN ARRAY_SUB2 THEN + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 4"); + END IF; + + IF ARRAY5 IN ARRAY_SUB3 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 5"); + END IF; + IF ARRAY6 NOT IN ARRAY_SUB3 THEN + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 6"); + END IF; + + IF NULL_ARRAY_1 IN ARRAY_SUB1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 7"); + END IF; + IF NULL_ARRAY_2 NOT IN ARRAY_SUB1 THEN + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 8"); + END IF; + + IF ARRAY7 IN CON_ARRAY1 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 9"); + END IF; + IF ARRAY8 NOT IN CON_ARRAY1 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 10"); + END IF; + + IF ARRAY9 IN CON_ARRAY2 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 11"); + END IF; + IF ARRAY10 NOT IN CON_ARRAY2 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 12"); + END IF; + + IF ARRAY11 IN CON_ARRAY3 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 13"); + END IF; + IF ARRAY12 NOT IN CON_ARRAY3 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 14"); + END IF; + + IF ARRAY13 IN ARRAY_SUB4 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 15"); + END IF; + IF ARRAY14 NOT IN ARRAY_SUB4 THEN + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 16"); + END IF; + + IF ARRAY15 IN CON_ARRAY4 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 17"); + END IF; + IF ARRAY16 NOT IN CON_ARRAY4 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 18"); + END IF; + + IF ARRAY17 IN ARRAY_SUB5 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 19"); + END IF; + IF ARRAY18 NOT IN ARRAY_SUB5 THEN + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 20"); + END IF; + + IF ARRAY19 IN CON_ARRAY5 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 21"); + END IF; + IF ARRAY20 NOT IN CON_ARRAY5 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 22"); + END IF; + + IF NULL_ARRAY_1 IN NULL_ARRAY1 THEN + FAILED ("INCORRECT RESULTS FOR NULL ARRAYS - 23"); + END IF; + IF NULL_ARRAY_2 NOT IN NULL_ARRAY1 THEN + FAILED ("INCORRECT RESULTS FOR NULL ARRAYS - 24"); + END IF; + + RESULT; +END C45265A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45271a.ada b/gcc/testsuite/ada/acats/tests/c4/c45271a.ada new file mode 100644 index 000000000..8e621993b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45271a.ada @@ -0,0 +1,112 @@ +-- C45271A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT EQUALITY AND INEQUALITY ARE EVALUATED CORRECTLY FOR +-- RECORDS WHOSE COMPONENTS DO NOT HAVE CHANGEABLE DISCRIMINANTS. + +-- TBN 8/6/86 + +WITH REPORT; USE REPORT; +PROCEDURE C45271A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 20; + TYPE ARRAY_BOOL IS ARRAY (1 .. 5) OF BOOLEAN; + + TYPE REC_TYPE1 IS + RECORD + BOOL : ARRAY_BOOL; + A : INTEGER; + END RECORD; + + TYPE REC_TYPE2 (LEN : INT := 3) IS + RECORD + A : STRING (1 .. LEN); + END RECORD; + + TYPE REC_TYPE3 (NUM : INT := 1) IS + RECORD + A : REC_TYPE1; + END RECORD; + + REC1, REC2 : REC_TYPE1 := (A => 2, OTHERS => (OTHERS => TRUE)); + REC3, REC4 : REC_TYPE2 (5) := (5, "WHERE"); + REC5, REC6 : REC_TYPE2; + REC7, REC8 : REC_TYPE3; + REC9, REC10 : REC_TYPE3 (3) := (NUM => 3, A => + (A => 5, BOOL => (OTHERS => FALSE))); + +BEGIN + TEST ("C45271A", "CHECK THAT EQUALITY AND INEQUALITY ARE " & + "EVALUATED CORRECTLY FOR RECORDS WHOSE " & + "COMPONENTS DO NOT HAVE CHANGEABLE " & + "DISCRIMINANTS"); + + IF "/=" (LEFT => REC1, RIGHT => REC2) THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 1"); + END IF; + REC1.A := IDENT_INT(1); + IF "=" (LEFT => REC2, RIGHT => REC1) THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 2"); + END IF; + + IF REC3 /= REC4 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 3"); + END IF; + REC4.A := IDENT_STR("12345"); + IF REC3 = REC4 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 4"); + END IF; + + REC5.A := IDENT_STR("WHO"); + REC6.A := IDENT_STR("WHY"); + IF REC5 = REC6 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 5"); + END IF; + REC5.A := "WHY"; + IF REC6 /= REC5 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 6"); + END IF; + + REC7.A.A := IDENT_INT(1); + REC7.A.BOOL := (OTHERS => IDENT_BOOL(TRUE)); + REC8.A.A := 1; + REC8.A.BOOL := (OTHERS => TRUE); + IF REC7 /= REC8 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 7"); + END IF; + REC8.A.BOOL := (OTHERS => IDENT_BOOL(FALSE)); + IF REC8 = REC7 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 8"); + END IF; + + IF "/=" (LEFT => REC9, RIGHT => REC10) THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 9"); + END IF; + REC9.A.A := IDENT_INT(1); + IF "=" (LEFT => REC9, RIGHT => REC10) THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 10"); + END IF; + + RESULT; +END C45271A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45272a.ada b/gcc/testsuite/ada/acats/tests/c4/c45272a.ada new file mode 100644 index 000000000..447d468df --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45272a.ada @@ -0,0 +1,105 @@ +-- C45272A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT EQUALITY AND INEQUALITY ARE EVALUATED CORRECTLY FOR +-- RECORDS WHOSE COMPONENTS HAVE CHANGEABLE DISCRIMINANTS, INCLUDING +-- RECORDS DESIGNATED BY ACCESS VALUES. + +-- TBN 8/7/86 + +WITH REPORT; USE REPORT; +PROCEDURE C45272A IS + + SUBTYPE INT IS INTEGER RANGE 0 .. 20; + TYPE VARSTR (LEN : INT := 0) IS + RECORD + VAL : STRING (1..LEN); + END RECORD; + TYPE VARREC IS + RECORD + A, B : VARSTR; + END RECORD; + + TYPE CELL2; + TYPE LINK IS ACCESS CELL2; + TYPE CELL1 (NAM_LEN : INT := 0) IS + RECORD + NAME : STRING (1..NAM_LEN); + END RECORD; + TYPE CELL2 IS + RECORD + ONE : CELL1; + TWO : CELL1; + NEW_LINK : LINK; + END RECORD; + + X, Y : VARREC; + FRONT : LINK := NEW CELL2'((5, "XXYZZ"), (5, "YYYZZ"), NULL); + BACK : LINK := NEW CELL2'((5, "XXYZZ"), (5, "YYYZZ"), NULL); + +BEGIN + TEST ("C45272A", "CHECK THAT EQUALITY AND INEQUALITY ARE " & + "EVALUATED CORRECTLY FOR RECORDS WHOSE " & + "COMPONENTS HAVE CHANGEABLE DISCRIMINANTS"); + + X := ((5, "AAAXX"), (5, "BBBYY")); + Y := ((5, "AAAZZ"), (5, "BBBYY")); + IF X = Y THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 1"); + END IF; + + X.A := (3, "HHH"); + Y.A := (IDENT_INT(3), IDENT_STR("HHH")); + IF X /= Y THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 2"); + END IF; + + IF FRONT.ALL /= BACK.ALL THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 3"); + END IF; + + BACK.NEW_LINK := FRONT; + IF FRONT.ALL = BACK.ALL THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 4"); + END IF; + + FRONT.NEW_LINK := FRONT; + IF FRONT.ALL /= BACK.ALL THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 5"); + END IF; + + FRONT.ONE := (5, "XXXXX"); + BACK.ONE := (5, "ZZZZZ"); + IF FRONT.ALL = BACK.ALL THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 6"); + END IF; + + FRONT.ONE := (3, "XXX"); + BACK.ONE := (3, "XXX"); + IF FRONT.ALL /= BACK.ALL THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 7"); + END IF; + + RESULT; +END C45272A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45273a.ada b/gcc/testsuite/ada/acats/tests/c4/c45273a.ada new file mode 100644 index 000000000..ae74c2957 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45273a.ada @@ -0,0 +1,133 @@ +-- C45273A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT EQUALITY AND INEQUALITY ARE EVALUATED CORRECTLY FOR +-- RECORD OBJECTS HAVING DIFFERENT VALUES OF THE 'CONSTRAINED +-- ATTRIBUTE. + +-- HISTORY: +-- TBN 08/07/86 CREATED ORIGINAL TEST. +-- VCL 10/27/87 MODIFIED THIS HEADER; RELOCATED THE CALL TO +-- REPORT.TEST SO THAT IT COMES BEFORE ANY +-- DECLARATIONS; CHANGED THE 'ELSEIF' CONDITION IN +-- THE PROCEDURE 'PROC' SO THAT IT REFERS TO THE +-- FORMAL PARAMETERS. + +WITH REPORT; USE REPORT; +PROCEDURE C45273A IS +BEGIN + TEST ("C45273A", "EQUALITY AND INEQUALITY ARE " & + "EVALUATED CORRECTLY FOR RECORD OBJECTS HAVING " & + "DIFFERENT VALUES OF THE 'CONSTRAINED' " & + " ATTRIBUTE"); + + DECLARE + SUBTYPE INT IS INTEGER RANGE 1 .. 20; + TYPE REC_TYPE1 IS + RECORD + A : INTEGER; + END RECORD; + + TYPE REC_TYPE2 (LEN : INT := 3) IS + RECORD + A : STRING (1 .. LEN); + END RECORD; + + TYPE REC_TYPE3 (NUM : INT := 1) IS + RECORD + A : REC_TYPE1; + END RECORD; + + REC1 : REC_TYPE2 (3) := (3, "WHO"); + REC2 : REC_TYPE2; + REC3 : REC_TYPE2 (5) := (5, "WHERE"); + REC4 : REC_TYPE3; + REC5 : REC_TYPE3 (1) := (1, A => (A => 5)); + + PROCEDURE PROC (PREC1 : REC_TYPE2; + PREC2 : IN OUT REC_TYPE2) IS + BEGIN + IF NOT (PREC1'CONSTRAINED) OR PREC2'CONSTRAINED THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 6"); + ELSIF PREC1 /= PREC2 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 6"); + END IF; + PREC2.A := "WHO"; + END PROC; + + BEGIN + REC2.A := "WHO"; + IF NOT (REC1'CONSTRAINED) OR REC2'CONSTRAINED THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 1"); + ELSIF REC1 /= REC2 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 1"); + END IF; + + IF REC2'CONSTRAINED OR NOT (REC3'CONSTRAINED) THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 2"); + ELSIF REC2 = REC3 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 2"); + END IF; + + REC2 := (5, "WHERE"); + IF REC2'CONSTRAINED OR NOT (REC3'CONSTRAINED) THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 3"); + ELSIF REC2 /= REC3 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 3"); + END IF; + + REC4.A.A := 5; + IF REC4'CONSTRAINED OR NOT (REC5'CONSTRAINED) THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 4"); + ELSIF REC4 /= REC5 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 4"); + END IF; + + REC5.A := (A => 6); + IF REC4'CONSTRAINED OR NOT (REC5'CONSTRAINED) THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 5"); + ELSIF REC4 = REC5 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 5"); + END IF; + + REC1.A := "WHY"; + REC2 := (3, "WHY"); + PROC (REC1, REC2); + IF NOT (REC1'CONSTRAINED) OR REC2'CONSTRAINED THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 7"); + ELSIF REC1 = REC2 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 7"); + END IF; + END; + + RESULT; +END C45273A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45274a.ada b/gcc/testsuite/ada/acats/tests/c4/c45274a.ada new file mode 100644 index 000000000..ea7473192 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45274a.ada @@ -0,0 +1,222 @@ +-- C45274A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE MEMBERSHIP OPERATOR IN ( NOT IN ) ALWAYS +-- YIELDS TRUE (RESP. FALSE ) FOR +-- +-->> * RECORD TYPES WITHOUT DISCRIMINANTS; +-->> * PRIVATE TYPES WITHOUT DISCRIMINANTS; +-->> * LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS; +-- * (UNCONSTRAINED) RECORD TYPES WITH DISCRIMINANTS; +-- * (UNCONSTRAINED) PRIVATE TYPES WITH DISCRIMINANTS; +-- * (UNCONSTRAINED) LIMITED PRIVATE TYPES WITH DISCRIMINANTS. + + +-- RM 3/01/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C45274A IS + + +BEGIN + + TEST ( "C45274A" , "CHECK THAT THE MEMBERSHIP OPERATOR IN " & + " ( NOT IN ) YIELDS TRUE (RESP. FALSE )" & + " FOR RECORD TYPES WITHOUT DISCRIMINANTS," & + " PRIVATE TYPES WITHOUT DISCRIMINANTS, AND" & + " LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS"); + + + ------------------------------------------------------------------- + ----------------- RECORD TYPES WITHOUT DISCRIMINANTS ------------ + + DECLARE + + TYPE REC IS + RECORD + A , B : INTEGER ; + END RECORD ; + + X : REC := ( 19 , 91 ); + + BEGIN + + IF X IN REC THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 1" ); + END IF; + + IF X NOT IN REC THEN + FAILED( "WRONG VALUE: 'NOT IN', 1" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "1 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + + ------------------------------------------------------------------- + ----------------- PRIVATE TYPES WITHOUT DISCRIMINANTS ----------- + + DECLARE + + PACKAGE P IS + TYPE PRIV IS PRIVATE; + PRIVATE + TYPE PRIV IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + X : PRIV ; + + PACKAGE BODY P IS + BEGIN + X := ( 19 , 91 ); + END P ; + + BEGIN + + IF X IN PRIV THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 2" ); + END IF; + + IF X NOT IN PRIV THEN + FAILED( "WRONG VALUE: 'NOT IN', 2" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "2 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + ------------------------------------------------------------------- + --------- LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS ----------- + + DECLARE + + PACKAGE P IS + TYPE LP IS LIMITED PRIVATE; + PRIVATE + TYPE LP IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + X : LP ; + + PACKAGE BODY P IS + BEGIN + X := ( 19 , 91 ); + END P ; + + BEGIN + + IF X IN LP THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 3" ); + END IF; + + IF X NOT IN LP THEN + FAILED( "WRONG VALUE: 'NOT IN', 3" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "3 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + ------------------------------------------------------------------- + + DECLARE + + PACKAGE P IS + TYPE LP IS LIMITED PRIVATE; + PRIVATE + TYPE LP IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + Y : LP ; + + -- CHECK THAT NO EXCEPTION FOR UNINITIALIZED VARIABLE + BEGIN + + IF Y IN LP THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 3BIS" ); + END IF; + + IF Y NOT IN LP THEN + FAILED( "WRONG VALUE: 'NOT IN', 3BIS" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "3BIS - UNINITIALIZED VARIABLE - 'IN' " & + "( 'NOT IN' ) RAISED AN EXCEPTION" ); + + END; + + + ------------------------------------------------------------------- + + + RESULT; + + +END C45274A ; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45274b.ada b/gcc/testsuite/ada/acats/tests/c4/c45274b.ada new file mode 100644 index 000000000..4833b6d7d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45274b.ada @@ -0,0 +1,229 @@ +-- C45274B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE MEMBERSHIP OPERATOR IN ( NOT IN ) ALWAYS +-- YIELDS TRUE (RESP. FALSE ) FOR +-- +-- * RECORD TYPES WITHOUT DISCRIMINANTS; +-- * PRIVATE TYPES WITHOUT DISCRIMINANTS; +-- * LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS; +-->> * (UNCONSTRAINED) RECORD TYPES WITH DISCRIMINANTS; +-->> * (UNCONSTRAINED) PRIVATE TYPES WITH DISCRIMINANTS; +-->> * (UNCONSTRAINED) LIMITED PRIVATE TYPES WITH DISCRIMINANTS. + + +-- RM 3/03/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C45274B IS + + +BEGIN + + TEST ( "C45274B" , "CHECK THAT THE MEMBERSHIP OPERATOR IN " & + " ( NOT IN ) YIELDS TRUE (RESP. FALSE )" & + " FOR UNCONSTRAINED TYPES WITH DISCRIMINANTS" ); + + + ------------------------------------------------------------------- + -------- UNCONSTRAINED RECORD TYPES WITH DISCRIMINANTS ---------- + + DECLARE + + TYPE REC ( DISCR : BOOLEAN ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + + X : REC(FALSE) := ( FALSE , 19 , 81 ); + + TYPE REC0 ( DISCR : BOOLEAN := FALSE ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + + Y : REC0 := ( TRUE , 19 , 81 ); + + BEGIN + + IF X IN REC THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 1A" ); + END IF; + + IF Y NOT IN REC0 THEN + FAILED( "WRONG VALUE: 'NOT IN', 1B" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "1 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + + ------------------------------------------------------------------- + ------- UNCONSTRAINED PRIVATE TYPES WITH DISCRIMINANTS ---------- + + DECLARE + + PACKAGE P IS + TYPE PRIV ( DISCR : BOOLEAN ) IS PRIVATE; + PRIVATE + TYPE PRIV ( DISCR : BOOLEAN ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + X : PRIV(FALSE) ; + + PACKAGE BODY P IS + BEGIN + X := ( FALSE , 19 , 91 ); + END P ; + + BEGIN + + IF X IN PRIV THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 2" ); + END IF; + + IF X NOT IN PRIV THEN + FAILED( "WRONG VALUE: 'NOT IN', 2" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "2 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + + ------------------------------------------------------------------- + --------- UNCONSTRAINED LIM. PRIV. TYPES WITH DISCRIM. ---------- + + DECLARE + + PACKAGE P IS + TYPE LP ( DISCR : BOOLEAN := FALSE ) IS LIMITED PRIVATE; + PRIVATE + TYPE LP ( DISCR : BOOLEAN := FALSE ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + X : LP(TRUE) ; + + PACKAGE BODY P IS + BEGIN + X := ( TRUE , 19 , 91 ); + END P ; + + BEGIN + + IF X IN LP THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 3" ); + END IF; + + IF X NOT IN LP THEN + FAILED( "WRONG VALUE: 'NOT IN', 3" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "3 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + + ------------------------------------------------------------------- + + DECLARE + + PACKAGE P IS + TYPE LP ( DISCR : BOOLEAN := FALSE ) IS LIMITED PRIVATE; + PRIVATE + TYPE LP ( DISCR : BOOLEAN := FALSE ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + Y : LP(TRUE) ; + + -- CHECK THAT NO EXCEPTION FOR UNINITIALIZED VARIABLE + BEGIN + + IF Y IN LP THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 3BIS" ); + END IF; + + IF Y NOT IN LP THEN + FAILED( "WRONG VALUE: 'NOT IN', 3BIS" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "3BIS - UNINITIALIZED VARIABLE - 'IN' " & + "( 'NOT IN' ) RAISED AN EXCEPTION" ); + + END; + + + ------------------------------------------------------------------- + + + RESULT; + + +END C45274B ; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45274c.ada b/gcc/testsuite/ada/acats/tests/c4/c45274c.ada new file mode 100644 index 000000000..647089782 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45274c.ada @@ -0,0 +1,187 @@ +-- C45274C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE MEMBERSHIP OPERATOR IN ( NOT IN ) +-- YIELDS TRUE (RESP. FALSE ) IF THE DISCRIMINANTS OF THE LEFT +-- VALUE EQUAL THE DISCRIMINANTS OF THE SUBTYPE INDICATION. +-- +-- +-- * RECORD TYPES WITH DISCRIMINANTS; +-- * PRIVATE TYPES WITH DISCRIMINANTS; +-- * LIMITED PRIVATE TYPES WITH DISCRIMINANTS. + + +-- RM 3/01/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C45274C IS + + +BEGIN + + TEST ( "C45274C" , "CHECK THAT THE MEMBERSHIP OPERATOR IN " & + " ( NOT IN ) YIELDS TRUE (RESP. FALSE )" & + " IF THE DISCRIMINANTS OF THE LEFT VALUE" & + " EQUAL THE DISCRIMINANTS OF THE SUBTYPE" & + " INDICATION" ); + + + ------------------------------------------------------------------- + ----------------- RECORD TYPES WITH DISCRIMINANTS --------------- + + DECLARE + + TYPE REC ( DISCR : BOOLEAN := FALSE ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + + SUBTYPE RECTRUE IS REC(TRUE) ; + + X : REC := ( TRUE , 19 , 91 ); + + BEGIN + + IF X IN RECTRUE THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 1" ); + END IF; + + IF X NOT IN RECTRUE THEN + FAILED( "WRONG VALUE: 'NOT IN', 1" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "1 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + + ------------------------------------------------------------------- + ----------------- PRIVATE TYPES WITH DISCRIMINANTS -------------- + + DECLARE + + PACKAGE P IS + TYPE PRIV ( DISCR : BOOLEAN ) IS PRIVATE; + PRIVATE + TYPE PRIV ( DISCR : BOOLEAN ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + SUBTYPE PRIVTRUE IS PRIV( IDENT_BOOL(TRUE) ); + + X : PRIV(TRUE) ; + + PACKAGE BODY P IS + BEGIN + X := ( TRUE , 19 , 91 ); + END P ; + + BEGIN + + IF X IN PRIVTRUE THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 2" ); + END IF; + + IF X NOT IN PRIVTRUE THEN + FAILED( "WRONG VALUE: 'NOT IN', 2" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "2 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + ------------------------------------------------------------------- + --------- LIMITED PRIVATE TYPES WITH DISCRIMINANTS -------------- + + DECLARE + + PACKAGE P IS + TYPE LP ( DISCR : BOOLEAN := FALSE ) IS LIMITED PRIVATE; + PRIVATE + TYPE LP ( DISCR : BOOLEAN := FALSE ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + SUBTYPE LPFALSE IS LP(FALSE) ; + + X : LP(TRUE) ; + + PACKAGE BODY P IS + BEGIN + X := ( IDENT_BOOL(TRUE) , 19 , 91 ); + END P ; + + BEGIN + + IF X IN LPFALSE THEN + FAILED( "WRONG VALUE: 'IN', 3" ); + ELSE + NULL; + END IF; + + IF X NOT IN LPFALSE THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'NOT IN', 3" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "3 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + + ------------------------------------------------------------------- + + + RESULT; + + +END C45274C ; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45281a.ada b/gcc/testsuite/ada/acats/tests/c4/c45281a.ada new file mode 100644 index 000000000..24353f1ce --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45281a.ada @@ -0,0 +1,84 @@ +-- C45281A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT EQUALITY AND INEQUALITY ARE EVALUATED CORRECTLY FOR ACCESS +-- TYPES. + +-- TBN 8/8/86 + +WITH REPORT; USE REPORT; +PROCEDURE C45281A IS + + TYPE STR_NAME IS ACCESS STRING; + + TYPE GENDER IS (F, M); + TYPE PERSON (SEX : GENDER) IS + RECORD + NAME : STRING (1..6) := "NONAME"; + END RECORD; + + TYPE PERSON_NAME IS ACCESS PERSON; + SUBTYPE MALE IS PERSON_NAME (M); + SUBTYPE FEMALE IS PERSON_NAME (F); + + S : STR_NAME (1..10) := NEW STRING'("0123456789"); + T : STR_NAME (1..10) := S; + A : MALE; + B : FEMALE; + C : PERSON_NAME; + +BEGIN + TEST ("C45281A", "CHECK THAT EQUALITY AND INEQUALITY ARE " & + "EVALUATED CORRECTLY FOR ACCESS TYPES"); + + IF "/=" (LEFT => S, RIGHT => T) THEN + FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 1"); + END IF; + T := NEW STRING'("0123456789"); + IF "=" (S, T) THEN + FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 2"); + END IF; + + IF A /= B THEN + FAILED ("INCORRECT RESULTS FOR NULL ACCESS VALUES - 3"); + END IF; + IF A /= C THEN + FAILED ("INCORRECT RESULTS FOR NULL ACCESS VALUES - 4"); + END IF; + + A := NEW PERSON'(M, "THOMAS"); + IF "=" (LEFT => A, RIGHT => B) THEN + FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 5"); + END IF; + C := A; + IF C /= A THEN + FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 6"); + END IF; + C := NEW PERSON'(M, "THOMAS"); + IF A = C THEN + FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 7"); + END IF; + + RESULT; +END C45281A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45282a.ada b/gcc/testsuite/ada/acats/tests/c4/c45282a.ada new file mode 100644 index 000000000..e248e3ae2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45282a.ada @@ -0,0 +1,170 @@ +-- C45282A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IN AND NOT IN ARE EVALUATED CORRECTLY FOR : +-- A) ACCESS TO SCALAR TYPES; +-- B) ACCESS TO ARRAY TYPES (CONSTRAINED AND UNCONSTRAINED); +-- C) ACCESS TO RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITHOUT +-- DISCRIMINANTS; + +-- TBN 8/8/86 + +WITH REPORT; USE REPORT; +PROCEDURE C45282A IS + + PACKAGE P IS + TYPE KEY IS PRIVATE; + FUNCTION INIT_KEY (X : NATURAL) RETURN KEY; + TYPE NEWKEY IS LIMITED PRIVATE; + TYPE ACC_NKEY IS ACCESS NEWKEY; + PROCEDURE ASSIGN_NEWKEY (Y : IN OUT ACC_NKEY); + PRIVATE + TYPE KEY IS NEW NATURAL; + TYPE NEWKEY IS NEW KEY; + END P; + + USE P; + SUBTYPE I IS INTEGER; + TYPE ACC_INT IS ACCESS I; + P_INT : ACC_INT; + SUBTYPE INT IS INTEGER RANGE 1 .. 5; + TYPE ARRAY_TYPE1 IS ARRAY (INT RANGE <>) OF INTEGER; + TYPE ACC_ARA_1 IS ACCESS ARRAY_TYPE1; + SUBTYPE ACC_ARA_2 IS ACC_ARA_1 (1 .. 2); + SUBTYPE ACC_ARA_3 IS ACC_ARA_1 (1 .. 3); + ARA1 : ACC_ARA_1; + ARA2 : ACC_ARA_2; + ARA3 : ACC_ARA_3; + TYPE GREET IS + RECORD + NAME : STRING (1 .. 2); + END RECORD; + TYPE ACC_GREET IS ACCESS GREET; + INTRO : ACC_GREET; + TYPE ACC_KEY IS ACCESS KEY; + KEY1 : ACC_KEY; + KEY2 : ACC_NKEY; + + PACKAGE BODY P IS + FUNCTION INIT_KEY (X : NATURAL) RETURN KEY IS + BEGIN + RETURN (KEY(X)); + END INIT_KEY; + + PROCEDURE ASSIGN_NEWKEY (Y : IN OUT ACC_NKEY) IS + BEGIN + Y.ALL := NEWKEY (1); + END ASSIGN_NEWKEY; + END P; + +BEGIN + + TEST ("C45282A", "CHECK THAT IN AND NOT IN ARE EVALUATED FOR " & + "ACCESS TYPES TO SCALAR TYPES, ARRAY TYPES, " & + "RECORD TYPES, PRIVATE TYPES, AND LIMITED " & + "PRIVATE TYPES WITHOUT DISCRIMINANTS"); + +-- CASE A + IF P_INT NOT IN ACC_INT THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 1"); + END IF; + P_INT := NEW INT'(5); + IF P_INT IN ACC_INT THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 2"); + END IF; + +-- CASE B + IF ARA1 NOT IN ACC_ARA_1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 3"); + END IF; + IF ARA1 NOT IN ACC_ARA_2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 4"); + END IF; + IF ARA1 IN ACC_ARA_3 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 5"); + END IF; + IF ARA2 IN ACC_ARA_1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 6"); + END IF; + IF ARA3 NOT IN ACC_ARA_1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 7"); + END IF; + ARA1 := NEW ARRAY_TYPE1'(1, 2, 3); + IF ARA1 IN ACC_ARA_1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 8"); + END IF; + IF ARA1 IN ACC_ARA_2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 9"); + END IF; + IF ARA1 NOT IN ACC_ARA_3 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 10"); + END IF; + ARA2 := NEW ARRAY_TYPE1'(1, 2); + IF ARA2 NOT IN ACC_ARA_1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 11"); + END IF; + IF ARA2 NOT IN ACC_ARA_2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 12"); + END IF; + +-- CASE C + IF INTRO NOT IN ACC_GREET THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 13"); + END IF; + INTRO := NEW GREET'(NAME => "HI"); + IF INTRO IN ACC_GREET THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 14"); + END IF; + IF KEY1 NOT IN ACC_KEY THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 15"); + END IF; + KEY1 := NEW KEY'(INIT_KEY (1)); + IF KEY1 IN ACC_KEY THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 16"); + END IF; + IF KEY2 NOT IN ACC_NKEY THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 17"); + END IF; + KEY2 := NEW NEWKEY; + ASSIGN_NEWKEY (KEY2); + IF KEY2 IN ACC_NKEY THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 18"); + END IF; + + RESULT; +END C45282A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45282b.ada b/gcc/testsuite/ada/acats/tests/c4/c45282b.ada new file mode 100644 index 000000000..af3a2bf2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45282b.ada @@ -0,0 +1,347 @@ +-- C45282B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IN AND NOT IN ARE EVALUATED CORRECTLY FOR : +-- D) ACCESS TO RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH +-- DISCRIMINANTS (WITH AND WITHOUT DEFAULT VALUES), WHERE THE +-- TYPE MARK DENOTES A CONSTRAINED AND UNCONSTRAINED TYPE; +-- E) ACCESS TO TASK TYPES. + +-- TBN 8/8/86 + +WITH REPORT; USE REPORT; +PROCEDURE C45282B IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 5; + + PACKAGE P IS + TYPE PRI_REC1 (D : INT) IS PRIVATE; + TYPE PRI_REC2 (D : INT := 2) IS PRIVATE; + FUNCTION INIT_PREC1 (A : INT; B : STRING) RETURN PRI_REC1; + FUNCTION INIT_PREC2 (A : INT; B : STRING) RETURN PRI_REC2; + TYPE LIM_REC1 (D : INT) IS LIMITED PRIVATE; + TYPE ACC_LIM1 IS ACCESS LIM_REC1; + SUBTYPE ACC_SUB_LIM1 IS ACC_LIM1 (2); + PROCEDURE ASSIGN_LIM1 (A : ACC_LIM1; B : INT; C : STRING); + TYPE LIM_REC2 (D : INT := 2) IS LIMITED PRIVATE; + TYPE ACC_LIM2 IS ACCESS LIM_REC2; + SUBTYPE ACC_SUB_LIM2 IS ACC_LIM2 (2); + PROCEDURE ASSIGN_LIM2 (A : ACC_LIM2; B : INT; C : STRING); + PRIVATE + TYPE PRI_REC1 (D : INT) IS + RECORD + STR : STRING (1 .. D); + END RECORD; + TYPE PRI_REC2 (D : INT := 2) IS + RECORD + STR : STRING (1 .. D); + END RECORD; + TYPE LIM_REC1 (D : INT) IS + RECORD + STR : STRING (1 .. D); + END RECORD; + TYPE LIM_REC2 (D : INT := 2) IS + RECORD + STR : STRING (1 .. D); + END RECORD; + END P; + + USE P; + + TYPE DIS_REC1 (D : INT) IS + RECORD + STR : STRING (1 .. D); + END RECORD; + TYPE DIS_REC2 (D : INT := 5) IS + RECORD + STR : STRING (D .. 8); + END RECORD; + + TYPE ACC1_REC1 IS ACCESS DIS_REC1; + SUBTYPE ACC2_REC1 IS ACC1_REC1 (2); + TYPE ACC1_REC2 IS ACCESS DIS_REC2; + SUBTYPE ACC2_REC2 IS ACC1_REC2 (2); + REC1 : ACC1_REC1; + REC2 : ACC2_REC1; + REC3 : ACC1_REC2; + REC4 : ACC2_REC2; + TYPE ACC_PREC1 IS ACCESS PRI_REC1; + SUBTYPE ACC_SREC1 IS ACC_PREC1 (2); + REC5 : ACC_PREC1; + REC6 : ACC_SREC1; + TYPE ACC_PREC2 IS ACCESS PRI_REC2; + SUBTYPE ACC_SREC2 IS ACC_PREC2 (2); + REC7 : ACC_PREC2; + REC8 : ACC_SREC2; + REC9 : ACC_LIM1; + REC10 : ACC_SUB_LIM1; + REC11 : ACC_LIM2; + REC12 : ACC_SUB_LIM2; + + TASK TYPE T IS + ENTRY E (X : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : INTEGER) DO + IF X /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE PASSED TO TASK"); + END IF; + END E; + END T; + + PACKAGE BODY P IS + FUNCTION INIT_PREC1 (A : INT; B : STRING) RETURN PRI_REC1 IS + REC : PRI_REC1 (A); + BEGIN + REC := (A, B); + RETURN (REC); + END INIT_PREC1; + + FUNCTION INIT_PREC2 (A : INT; B : STRING) RETURN PRI_REC2 IS + REC : PRI_REC2; + BEGIN + REC := (A, B); + RETURN (REC); + END INIT_PREC2; + + PROCEDURE ASSIGN_LIM1 (A : ACC_LIM1; B : INT; C : STRING) IS + BEGIN + A.ALL := (B, C); + END ASSIGN_LIM1; + + PROCEDURE ASSIGN_LIM2 (A : ACC_LIM2; B : INT; C : STRING) IS + BEGIN + A.ALL := (B, C); + END ASSIGN_LIM2; + END P; + +BEGIN + + TEST ("C45282B", "CHECK THAT IN AND NOT IN ARE EVALUATED FOR " & + "ACCESS TYPES TO RECORD TYPES, PRIVATE TYPES, " & + "LIMITED PRIVATE TYPES WITH DISCRIMINANTS, AND " & + "TASK TYPES"); + +-- CASE D +------------------------------------------------------------------------ + IF REC1 NOT IN ACC1_REC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 1"); + END IF; + IF REC1 IN ACC2_REC1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 2"); + END IF; + IF REC2 NOT IN ACC1_REC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 3"); + END IF; + REC1 := NEW DIS_REC1'(5, "12345"); + IF REC1 IN ACC1_REC1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 4"); + END IF; + IF REC1 IN ACC2_REC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 5"); + END IF; + REC2 := NEW DIS_REC1'(2, "HI"); + IF REC2 IN ACC1_REC1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 6"); + END IF; + +------------------------------------------------------------------------ + + IF REC3 IN ACC1_REC2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 7"); + END IF; + IF REC3 NOT IN ACC2_REC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 8"); + END IF; + IF REC4 IN ACC1_REC2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 9"); + END IF; + REC3 := NEW DIS_REC2'(5, "5678"); + IF REC3 IN ACC1_REC2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 10"); + END IF; + IF REC3 IN ACC2_REC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 11"); + END IF; + REC4 := NEW DIS_REC2'(2, "2345678"); + IF REC4 IN ACC1_REC2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 12"); + END IF; + IF REC4 NOT IN ACC2_REC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 13"); + END IF; + +------------------------------------------------------------------------ + + IF REC5 NOT IN ACC_PREC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 14"); + END IF; + IF REC5 NOT IN ACC_SREC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 15"); + END IF; + IF REC6 NOT IN ACC_PREC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 16"); + END IF; + REC5 := NEW PRI_REC1'(INIT_PREC1 (5, "12345")); + IF REC5 IN ACC_PREC1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 17"); + END IF; + IF REC5 IN ACC_SREC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 18"); + END IF; + REC6 := NEW PRI_REC1'(INIT_PREC1 (2, "HI")); + IF REC6 IN ACC_PREC1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 19"); + END IF; + +------------------------------------------------------------------------ + + IF REC7 NOT IN ACC_PREC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 20"); + END IF; + IF REC7 NOT IN ACC_SREC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 21"); + END IF; + IF REC8 NOT IN ACC_PREC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 22"); + END IF; + REC7 := NEW PRI_REC2'(INIT_PREC2 (5, "12345")); + IF REC7 IN ACC_PREC2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 23"); + END IF; + IF REC7 IN ACC_SREC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 24"); + END IF; + REC8 := NEW PRI_REC2'(INIT_PREC2 (2, "HI")); + IF REC8 IN ACC_PREC2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 25"); + END IF; + +------------------------------------------------------------------------ + + IF REC9 NOT IN ACC_LIM1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 26"); + END IF; + IF REC9 NOT IN ACC_SUB_LIM1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 27"); + END IF; + IF REC10 NOT IN ACC_LIM1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 28"); + END IF; + REC9 := NEW LIM_REC1 (5); + ASSIGN_LIM1 (REC9, 5, "12345"); + IF REC9 IN ACC_LIM1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 29"); + END IF; + IF REC9 IN ACC_SUB_LIM1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 30"); + END IF; + REC10 := NEW LIM_REC1 (2); + ASSIGN_LIM1 (REC10, 2, "12"); + IF REC10 IN ACC_LIM1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 31"); + END IF; + +------------------------------------------------------------------------ + + IF REC11 NOT IN ACC_LIM2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 32"); + END IF; + IF REC11 NOT IN ACC_SUB_LIM2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 33"); + END IF; + IF REC12 NOT IN ACC_LIM2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 34"); + END IF; + REC11 := NEW LIM_REC2; + IF REC11 NOT IN ACC_SUB_LIM2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 35"); + END IF; + ASSIGN_LIM2 (REC11, 2, "12"); + IF REC11 IN ACC_LIM2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 36"); + END IF; + IF REC11 IN ACC_SUB_LIM2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 37"); + END IF; + REC12 := NEW LIM_REC2; + ASSIGN_LIM2 (REC12, 2, "12"); + IF REC12 IN ACC_LIM2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 38"); + END IF; + +-- CASE E +------------------------------------------------------------------------ + DECLARE + TYPE ACC_TASK IS ACCESS T; + T1 : ACC_TASK; + BEGIN + IF T1 NOT IN ACC_TASK THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 39"); + END IF; + T1 := NEW T; + IF T1 IN ACC_TASK THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 38"); + END IF; + T1.E (1); + END; + + RESULT; +END C45282B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45291a.ada b/gcc/testsuite/ada/acats/tests/c4/c45291a.ada new file mode 100644 index 000000000..86c9eb2d8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45291a.ada @@ -0,0 +1,158 @@ +-- C45291A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE MEMBERSHIP TESTS YIELD CORRECT RESULTS FOR TASK +-- TYPES, LIMITED PRIVATE TYPES, COMPOSITE LIMITED TYPES, AND +-- PRIVATE TYPES WITHOUT DISCRIMINANTS. + +-- HISTORY: +-- JET 08/10/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45291A IS + + TASK TYPE TASK1 IS + ENTRY E; + END TASK1; + + PACKAGE PACK IS + TYPE LIM_PRIV IS LIMITED PRIVATE; + TYPE LIM_COMP IS ARRAY (1..10) OF LIM_PRIV; + TYPE PRIV IS PRIVATE; + PROCEDURE INIT(LP : OUT LIM_PRIV; + LC : IN OUT LIM_COMP; + P : OUT PRIV); + PRIVATE + TYPE LIM_PRIV IS RANGE -100..100; + TYPE PRIV IS RECORD + I : INTEGER; + END RECORD; + END PACK; + + SUBTYPE SUB_TASK1 IS TASK1; + SUBTYPE SUB_LIM_PRIV IS PACK.LIM_PRIV; + SUBTYPE SUB_LIM_COMP IS PACK.LIM_COMP; + SUBTYPE SUB_PRIV IS PACK.PRIV; + + T1 : TASK1; + LP : PACK.LIM_PRIV; + LC : PACK.LIM_COMP; + P : PACK.PRIV; + + TASK BODY TASK1 IS + BEGIN + ACCEPT E DO + NULL; + END E; + END TASK1; + + PACKAGE BODY PACK IS + PROCEDURE INIT (LP : OUT LIM_PRIV; + LC : IN OUT LIM_COMP; + P : OUT PRIV) IS + BEGIN + LP := 0; + LC := (OTHERS => 0); + P := (I => 0); + END INIT; + END PACK; + +BEGIN + TEST ("C45291A", "CHECK THAT THE MEMBERSHIP TESTS YIELD CORRECT " & + "RESULTS FOR TASK TYPES, LIMITED PRIVATE TYPES," & + " COMPOSITE LIMITED TYPES, AND PRIVATE TYPES " & + "WITHOUT DISCRIMINANTS"); + + PACK.INIT(LP, LC, P); + + IF NOT IDENT_BOOL(T1 IN TASK1) THEN + FAILED ("INCORRECT VALUE OF 'T1 IN TASK1'"); + END IF; + + IF IDENT_BOOL(T1 NOT IN TASK1) THEN + FAILED ("INCORRECT VALUE OF 'T1 NOT IN TASK1'"); + END IF; + + IF NOT IDENT_BOOL(LP IN PACK.LIM_PRIV) THEN + FAILED ("INCORRECT VALUE OF 'LP IN LIM_PRIV'"); + END IF; + + IF IDENT_BOOL(LP NOT IN PACK.LIM_PRIV) THEN + FAILED ("INCORRECT VALUE OF 'LP NOT IN LIM_PRIV'"); + END IF; + + IF NOT IDENT_BOOL(LC IN PACK.LIM_COMP) THEN + FAILED ("INCORRECT VALUE OF 'LC IN LIM_COMP'"); + END IF; + + IF IDENT_BOOL(LC NOT IN PACK.LIM_COMP) THEN + FAILED ("INCORRECT VALUE OF 'LC NOT IN LIM_COMP'"); + END IF; + + IF NOT IDENT_BOOL(P IN PACK.PRIV) THEN + FAILED ("INCORRECT VALUE OF 'P IN PRIV'"); + END IF; + + IF IDENT_BOOL(P NOT IN PACK.PRIV) THEN + FAILED ("INCORRECT VALUE OF 'P NOT IN PRIV'"); + END IF; + + IF NOT IDENT_BOOL(T1 IN SUB_TASK1) THEN + FAILED ("INCORRECT VALUE OF 'T1 IN SUB_TASK1'"); + END IF; + + IF IDENT_BOOL(T1 NOT IN SUB_TASK1) THEN + FAILED ("INCORRECT VALUE OF 'T1 NOT IN SUB_TASK1'"); + END IF; + + IF NOT IDENT_BOOL(LP IN SUB_LIM_PRIV) THEN + FAILED ("INCORRECT VALUE OF 'LP IN SUB_LIM_PRIV'"); + END IF; + + IF IDENT_BOOL(LP NOT IN SUB_LIM_PRIV) THEN + FAILED ("INCORRECT VALUE OF 'LP NOT IN SUB_LIM_PRIV'"); + END IF; + + IF NOT IDENT_BOOL(LC IN SUB_LIM_COMP) THEN + FAILED ("INCORRECT VALUE OF 'LC IN SUB_LIM_COMP'"); + END IF; + + IF IDENT_BOOL(LC NOT IN SUB_LIM_COMP) THEN + FAILED ("INCORRECT VALUE OF 'LC NOT IN SUB_LIM_COMP'"); + END IF; + + IF NOT IDENT_BOOL(P IN SUB_PRIV) THEN + FAILED ("INCORRECT VALUE OF 'P IN SUB_PRIV'"); + END IF; + + IF IDENT_BOOL(P NOT IN SUB_PRIV) THEN + FAILED ("INCORRECT VALUE OF 'P NOT IN SUB_PRIV'"); + END IF; + + T1.E; + + RESULT; + +END C45291A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45303a.ada b/gcc/testsuite/ada/acats/tests/c4/c45303a.ada new file mode 100644 index 000000000..01cd53dba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45303a.ada @@ -0,0 +1,80 @@ +-- C45303A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ADDITION AND SUBTRACTION YIELD RESULTS BELONGING TO THE +-- BASE TYPE. + +-- JBG 2/24/84 +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. +-- JRL 10/13/96 Fixed static expressions which contained values outside +-- the base range. + +WITH REPORT; USE REPORT; +PROCEDURE C45303A IS + + TYPE INT IS RANGE 1..10; + + X, Y : INT := INT(IDENT_INT(9)); + +BEGIN + + TEST ("C45303A", "CHECK SUBTYPE OF INTEGER ADDITION/SUBTRACTION"); + + BEGIN + + IF X + Y - 10 /= INT(IDENT_INT(8)) THEN + FAILED ("INCORRECT RESULT - ADDITION"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + IF INT'POS(INT'BASE'LAST) >= 18 THEN + FAILED ("ADDITION DOES NOT YIELD RESULT " & + "BELONGING TO THE BASE TYPE"); + ELSE + COMMENT ("BASE TYPE HAS RANGE LESS THAN 18 - ADD"); + END IF; + END; + + BEGIN + + IF 2 - X - INT(IDENT_INT(1)) /= INT'VAL(IDENT_INT(-8)) THEN + FAILED ("INCORRECT RESULT - SUBTRACTION"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + IF INT'POS(INT'BASE'FIRST) <= -8 THEN + FAILED ("SUBTRACTION DOES NOT YIELD RESULT " & + "BELONGING TO THE BASE TYPE"); + ELSE + COMMENT ("BASE TYPE HAS RANGE GREATER THAN -8 - SUB"); + END IF; + END; + + RESULT; + +END C45303A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45304a.ada b/gcc/testsuite/ada/acats/tests/c4/c45304a.ada new file mode 100644 index 000000000..8a5dfe991 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45304a.ada @@ -0,0 +1,82 @@ +-- C45304A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED BY +-- "+" AND "-" FOR PREDEFINED INTEGER WHEN THE RESULT IS OUTSIDE +-- THE RANGE OF THE BASE TYPE. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- HISTORY: +-- TBN 10/06/86 CREATED ORIGINAL TEST. +-- JET 12/29/87 FURTHER DEFEATED OPTIMIZATION. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45304A IS + +BEGIN + TEST ("C45304A", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED BY ""+"" AND ""-"" FOR PREDEFINED " & + "INTEGER WHEN THE RESULT IS OUTSIDE THE RANGE " & + "OF THE BASE TYPE"); + + DECLARE + B : INTEGER := INTEGER'LAST; + BEGIN + IF EQUAL (IDENT_INT(B)+1, 0) THEN + FAILED ("NO EXCEPTION FOR ADDITION -- ZERO RESULT"); + ELSE + FAILED ("NO EXCEPTION FOR ADDITION -- NONZERO RESULT"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR ADDITION"); + END; + + DECLARE + B : INTEGER := INTEGER'FIRST; + BEGIN + IF EQUAL (IDENT_INT(B)-1, 0) THEN + FAILED ("NO EXCEPTION FOR SUBTRACTION -- ZERO RESULT"); + ELSE + FAILED ("NO EXCEPTION FOR SUBTRACTION -- " & + "NONZERO RESULT"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR SUBTRACTION"); + END; + + RESULT; +END C45304A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45304b.dep b/gcc/testsuite/ada/acats/tests/c4/c45304b.dep new file mode 100644 index 000000000..23620f8b9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45304b.dep @@ -0,0 +1,111 @@ +-- C45304B.DEP + +-- 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 CONSTRAINT_ERROR IS RAISED BY +-- "+" AND "-" FOR PREDEFINED SHORT_INTEGER WHEN THE RESULT IS +-- OUTSIDE THE RANGE OF THE BASE TYPE. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE IF THE IMPLEMENTATION HAS A +-- PREDEFINED TYPE SHORT_INTEGER. + +-- IF SHORT_INTEGER IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "TEST_VAR" MUST BE REJECTED. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- HISTORY: +-- TBN 10/07/86 CREATED ORIGINAL TEST. +-- JET 12/30/87 ADDED CODE TO PREVENT OPTIMIZATION. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45304B IS + + TEST_VAR : SHORT_INTEGER; -- N/A => ERROR. + + -- THESE FUNCTIONS ARE TO PREVENT OPTIMIZATION. + + FUNCTION IDENT_SHORT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN (0); + END IF; + END IDENT_SHORT; + + FUNCTION SHORT_OK (X : SHORT_INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN EQUAL (INTEGER(X),INTEGER(X)); + END SHORT_OK; + +BEGIN + TEST ("C45304B", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED BY ""+"" AND ""-"" FOR PREDEFINED " & + "SHORT_INTEGER WHEN THE RESULT IS OUTSIDE THE " & + "RANGE OF THE BASE TYPE"); + + DECLARE + B : SHORT_INTEGER := SHORT_INTEGER'LAST; + BEGIN + IF SHORT_OK (B + IDENT_SHORT(1)) THEN + FAILED ("NO EXCEPTION RAISED FOR ADDITION - " & + "SHORT_OK RETURNS TRUE"); + ELSE + FAILED ("NO EXCEPTION RAISED FOR ADDITION - " & + "SHORT_OK RETURNS FALSE"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + DECLARE + B : SHORT_INTEGER := SHORT_INTEGER'FIRST; + BEGIN + + IF SHORT_OK (B - IDENT_SHORT(1)) THEN + FAILED ("NO EXCEPTION RAISED FOR SUBTRACTION- " & + "SHORT_OK RETURNS TRUE"); + ELSE + FAILED ("NO EXCEPTION RAISED FOR SUBTRACTION - " & + "SHORT_OK RETURNS FALSE"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + RESULT; +END C45304B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45304c.dep b/gcc/testsuite/ada/acats/tests/c4/c45304c.dep new file mode 100644 index 000000000..9eaba634f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45304c.dep @@ -0,0 +1,110 @@ +-- C45304C.DEP + +-- 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 CONSTRAINT_ERROR IS RAISED BY +-- "+" AND "-" FOR PREDEFINED LONG_INTEGER WHEN THE RESULT IS +-- OUTSIDE THE RANGE OF THE BASE TYPE. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE IF THE IMPLEMENTATION HAS A +-- PREDEFINED TYPE LONG_INTEGER. + +-- IF LONG_INTEGER IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "TEST_VAR" MUST BE REJECTED. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- HISTORY: +-- TBN 10/07/86 CREATED ORIGINAL TEST. +-- JET 12/30/87 ADDED CODE TO PREVENT OPTIMIZATION. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45304C IS + + TEST_VAR : LONG_INTEGER; -- N/A => ERROR. + + -- THESE FUNCTIONS ARE TO PREVENT OPTIMIZATION. + + FUNCTION IDENT_LONG (X : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN 0; + END IF; + END IDENT_LONG; + + FUNCTION LONG_OK (X : LONG_INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN X = IDENT_LONG(X); + END LONG_OK; + +BEGIN + TEST ("C45304C", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED BY ""+"" AND ""-"" FOR PREDEFINED " & + "LONG_INTEGER WHEN THE RESULT IS OUTSIDE THE " & + "RANGE OF THE BASE TYPE"); + + DECLARE + B : LONG_INTEGER := LONG_INTEGER'LAST; + BEGIN + IF LONG_OK (B + IDENT_LONG(1)) THEN + FAILED ("NO EXCEPTION RAISED FOR ADDITION - " & + "LONG_OK RETURNS TRUE"); + ELSE + FAILED ("NO EXCEPTION RAISED FOR ADDITION - " & + "LONG_OK RETURNS FALSE"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + DECLARE + B : LONG_INTEGER := LONG_INTEGER'FIRST; + BEGIN + IF LONG_OK (B - IDENT_LONG(1)) THEN + FAILED ("NO EXCEPTION RAISED FOR SUBTRACTION - " & + "LONG_OK RETURNS TRUE"); + ELSE + FAILED ("NO EXCEPTION RAISED FOR SUBTRACTION - " & + "LONG_OK RETURNS FALSE"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + RESULT; +END C45304C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45322a.ada b/gcc/testsuite/ada/acats/tests/c4/c45322a.ada new file mode 100644 index 000000000..8857c32f2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45322a.ada @@ -0,0 +1,196 @@ +-- C45322A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF +-- MACHINE_OVERFLOWS IS TRUE AND THE RESULT OF THE ADDITION OR +-- SUBTRACTION LIES OUTSIDE OF THE RANGE OF THE BASE TYPE. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- HISTORY: +-- NPL 09/01/90 CREATED ORIGINAL TEST. +-- LDC 10/09/90 CHANGED THE STYLE OF THE TEST TO THE STANDARD +-- ACVC FORMAT AND WRAPPED LINES WHICH WHERE LONGER +-- THAN 71 CHARACTERS. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C45322A IS + + TYPE FLOAT5 IS DIGITS 5; + F5 : FLOAT5; + + FUNCTION IDENT (F : FLOAT5) RETURN FLOAT5 IS + BEGIN + RETURN F * FLOAT5(IDENT_INT(1)); + END IDENT; + + FUNCTION EQUAL (F,G : FLOAT5) RETURN BOOLEAN IS + BEGIN + RETURN F = G + FLOAT5(IDENT_INT(0)); + END EQUAL; + +BEGIN + TEST ("C45322A", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED IF MACHINE_OVERFLOWS IS TRUE AND " & + "THE RESULT OF THE ADDITION OR SUBTRACTION " & + "LIES OUTSIDE OF THE RANGE OF THE BASE TYPE"); + + IF NOT FLOAT5'MACHINE_OVERFLOWS THEN + NOT_APPLICABLE("MACHINE_OVERFLOWS IS FALSE"); + ELSE + + BEGIN + F5 := IDENT(FLOAT5'BASE'LAST) + FLOAT5'BASE'LAST; + + FAILED("NO EXCEPTION RAISED BY LARGE '+'"); + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY LARGE '+'"); + END; + + -- AS ABOVE BUT INTERCHANGING '+' AND '-' + BEGIN + F5 := IDENT(FLOAT5'BASE'LAST) - FLOAT5'BASE'LAST; + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR " & + "RAISED BY INTERCHANGING LARGE '+'"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY " & + "INTERCHANGING LARGE '+'"); + END; + + BEGIN + F5 := IDENT(FLOAT5'BASE'FIRST) + FLOAT5'BASE'FIRST; + + FAILED("NO EXCEPTION RAISED BY SMALL '+'"); + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY SMALL '+'"); + END; + + -- AS ABOVE BUT INTERCHANGING '+' AND '-' + BEGIN + F5 := IDENT(FLOAT5'BASE'FIRST) - FLOAT5'BASE'FIRST; + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR " & + "RAISED BY INTERCHANGING SMALL '+'"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY " & + "INTERCHANGING SMALL '+'"); + END; + + BEGIN + F5 := IDENT(FLOAT5'BASE'LAST) - FLOAT5'BASE'FIRST; + + FAILED("NO EXCEPTION RAISED BY LARGE '-'"); + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY LARGE '-'"); + END; + + -- AS ABOVE BUT INTERCHANGING '+' AND '-' + BEGIN + F5 := IDENT(FLOAT5'BASE'LAST) + FLOAT5'BASE'FIRST; + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR " & + "RAISED BY INTERCHANGING LARGE '-'"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY " & + "INTERCHANGING LARGE '-'"); + END; + + BEGIN + F5 := IDENT(FLOAT5'BASE'FIRST) - FLOAT5'BASE'LAST; + + FAILED("NO EXCEPTION RAISED BY SMALL '-'"); + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY SMALL '-'"); + END; + + -- AS ABOVE BUT INTERCHANGING '+' AND '-' + BEGIN + F5 := IDENT(FLOAT5'BASE'FIRST) + FLOAT5'BASE'LAST; + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR " & + "RAISED BY INTERCHANGING SMALL '-'"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY " & + "INTERCHANGING SMALL '-'"); + END; + + END IF; + + RESULT; + +END C45322A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45323a.ada b/gcc/testsuite/ada/acats/tests/c4/c45323a.ada new file mode 100644 index 000000000..98c17d740 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45323a.ada @@ -0,0 +1,67 @@ +-- C45323A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE NONASSOCIATIVITY OF REAL ARITHMETIC IS PRESERVED +-- FOR FLOATING POINT PRECISION 5, EVEN WHEN OPTIMIZATION WOULD +-- BENEFIT IF FLOATING POINT ADDITION WERE ASSOCIATIVE. + +-- HISTORY: +-- JET 08/10/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45323A IS + + TYPE FLOAT5 IS DIGITS 5; + + A, B, C, D, E : FLOAT5; + + FUNCTION IDENT(F : FLOAT5) RETURN FLOAT5 IS + BEGIN + RETURN F * FLOAT5(IDENT_INT(1)); + END IDENT; + +BEGIN + TEST ("C45323A", "CHECK THAT THE NONASSOCIATIVITY OF REAL " & + "ARITHMETIC IS PRESERVED FOR FLOATING POINT " & + "PRECISION 5, EVEN WHEN OPTIMIZATION WOULD " & + "BENEFIT IF FLOATING POINT ADDITION WERE " & + "ASSOCIATIVE"); + + B := 2#0.1010_1010_1010_1010_10#E3; + A := -B; + C := 2#0.1000_0000_0000_0000_00#E-18; + D := B + C; + E := A + B + C; + + IF IDENT(A) + IDENT(B) /= 0.0 THEN + FAILED("INCORRECT VALUE OF A + B"); + END IF; + + IF IDENT(E) /= IDENT(C) THEN + FAILED("C DOES NOT EQUAL E"); + END IF; + + RESULT; +END C45323A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45331a.ada b/gcc/testsuite/ada/acats/tests/c4/c45331a.ada new file mode 100644 index 000000000..bdbcd6150 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45331a.ada @@ -0,0 +1,357 @@ +-- C45331A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR FIXED POINT TYPES THE OPERATORS "+" AND "-" PRODUCE +-- CORRECT RESULTS WHEN: +-- (A) A, B, A+B, AND A-B ARE ALL MODEL NUMBERS. +-- (B) A IS A MODEL NUMBER BUT B, A+B, AND A-B ARE NOT. +-- (C) A, B, A+B, AND A-B ARE ALL MODEL NUMBERS WITH DIFFERENT +-- SUBTYPES. + +-- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE. + +-- WRG 8/27/86 +-- KAS 11/14/95 REDUCE EXPECTATION FOR T'SMALL +-- KAS 11/30/95 ONE MORE CHANGE... +-- PWN 02/28/96 CLEANED COMMENTS FOR RELEASE +-- KAS 03/18/96 ELIDED TWO 'SMALL CASES FOR 2.1 + +WITH REPORT; USE REPORT; +PROCEDURE C45331A IS + + TYPE LIKE_DURATION IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + -- 'MANTISSA = 23. + SUBTYPE F IS LIKE_DURATION DELTA 0.25 RANGE -1000.0 .. 1000.0; + SUBTYPE ST_F1 IS LIKE_DURATION DELTA 0.5 RANGE -4.0 .. 3.0; + SUBTYPE ST_F2 IS LIKE_DURATION DELTA 1.0 / 16 + RANGE -13.0 / 16 .. 5.0 + 1.0 / 16; + +BEGIN + + TEST ("C45331A", "CHECK THAT FOR FIXED POINT TYPES THE " & + "OPERATORS ""+"" AND ""-"" PRODUCE CORRECT " & + "RESULTS - BASIC TYPES"); + + ------------------------------------------------------------------- + +A: DECLARE + SMALL, MAX, MIN, ZERO : F := 0.5; + X : F := 0.0; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + SMALL := F'SMALL; + MAX := F'LAST; -- BECAUSE F'LAST < F'LARGE AND F'LAST + -- IS A MODEL NUMBER. + MIN := F'FIRST; -- F'FIRST IS A MODEL NUMBER. + ZERO := 0.0; + END IF; + + -- CHECK SMALL + OR - ZERO = SMALL: + IF "+"(LEFT => SMALL, RIGHT => ZERO) /= SMALL OR + 0.0 + SMALL /= SMALL THEN + FAILED ("F'SMALL + 0.0 /= F'SMALL"); + END IF; + IF "-"(LEFT => SMALL, RIGHT => ZERO) /= SMALL OR + SMALL - 0.0 /= SMALL THEN + FAILED ("F'SMALL - 0.0 /= F'SMALL"); + END IF; + + -- CHECK MAX + OR - ZERO = MAX: + IF MAX + ZERO /= MAX OR 0.0 + MAX /= MAX THEN + FAILED ("F'LAST + 0.0 /= F'LAST"); + END IF; + IF MAX - ZERO /= MAX OR MAX - 0.0 /= MAX THEN + FAILED ("F'LAST - 0.0 /= F'LAST"); + END IF; + + -- CHECK SMALL - SMALL = 0.0: + IF EQUAL (3, 3) THEN + X := SMALL; + END IF; + IF SMALL - X /= 0.0 OR SMALL - SMALL /= 0.0 OR + F'SMALL - F'SMALL /= 0.0 THEN + FAILED ("F'SMALL - F'SMALL /= 0.0"); + END IF; + + -- CHECK MAX - MAX = 0.0: + IF EQUAL (3, 3) THEN + X := MAX; + END IF; + IF MAX - X /= 0.0 OR MAX - MAX /= 0.0 OR + F'LAST - F'LAST /= 0.0 THEN + FAILED ("F'LAST - F'LAST /= 0.0"); + END IF; + + -- CHECK ZERO - MAX = MIN, MIN - MIN = 0.0, + -- AND MIN + MAX = 0.0: + IF EQUAL (3, 3) THEN + X := ZERO - MAX; + END IF; + IF X /= MIN THEN + FAILED ("0.0 - 1000.0 /= -1000.0"); + END IF; + IF EQUAL (3, 3) THEN + X := MIN; + END IF; + IF MIN - X /= 0.0 OR MIN - MIN /= 0.0 OR + F'FIRST - F'FIRST /= 0.0 THEN + FAILED ("F'FIRST - F'FIRST /= 0.0"); + END IF; + IF MIN + MAX /= 0.0 OR MAX + MIN /= 0.0 OR + F'FIRST + F'LAST /= 0.0 THEN + FAILED ("-1000.0 + 1000.0 /= 0.0"); + END IF; + + -- CHECK ADDITION AND SUBTRACTION FOR ARBITRARY MID-RANGE + -- NUMBERS: + IF EQUAL (3, 3) THEN + X := 100.75; + END IF; + IF (X + SMALL) /= (SMALL + X) OR + (X + SMALL) > (X + 0.25) THEN -- X + SMALL SB <= X + DELTA + FAILED("X + SMALL DELIVERED BAD RESULT"); + END IF; + + -- CHECK (MAX - SMALL) + SMALL = MAX: + IF EQUAL (3, 3) THEN + X := MAX - SMALL; + END IF; + IF X + SMALL /= MAX THEN + FAILED("(MAX - SMALL) + SMALL /= MAX"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - A"); + END A; + + ------------------------------------------------------------------- + +B: DECLARE + NON_MODEL_CONST : CONSTANT := 2.0 / 3; + NON_MODEL_VAR : F := 0.0; + + SMALL, MAX, MIN, ZERO : F := 0.5; + X : F := 0.0; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + SMALL := F'SMALL; + MAX := F'LAST; -- BECAUSE F'LAST < F'LARGE AND + -- F'LAST IS A MODEL NUMBER. + MIN := F'FIRST; -- F'FIRST IS A MODEL NUMBER. + ZERO := 0.0; + NON_MODEL_VAR := NON_MODEL_CONST; + END IF; + + -- CHECK VALUE OF NON_MODEL_VAR: + IF NON_MODEL_VAR NOT IN 0.5 .. 0.75 THEN + FAILED ("VALUE OF NON_MODEL_VAR NOT IN CORRECT RANGE"); + END IF; + + -- CHECK NON-MODEL VALUE + OR - ZERO: + IF NON_MODEL_VAR + ZERO NOT IN 0.5 .. 0.75 OR + F'(0.0) + NON_MODEL_CONST NOT IN 0.5 .. 0.75 THEN + FAILED ("(2.0 / 3) + 0.0 NOT IN 0.5 .. 0.75"); + END IF; + IF NON_MODEL_VAR - ZERO NOT IN 0.5 .. 0.75 OR + NON_MODEL_CONST - F'(0.0) NOT IN 0.5 .. 0.75 THEN + FAILED ("(2.0 / 3) - 0.0 NOT IN 0.5 .. 0.75"); + END IF; + + -- CHECK ZERO - NON-MODEL: + IF F'(0.0) - NON_MODEL_CONST NOT IN -0.75 .. -0.5 THEN + FAILED ("0.0 - (2.0 / 3) NOT IN -0.75 .. -0.5"); + END IF; + + IF F'(1.0) - NON_MODEL_CONST NOT IN 0.25 .. 0.5 THEN + FAILED ("1.0 - (2.0 / 3) NOT IN 0.25 .. 0.5"); + END IF; + + -- CHECK ADDITION AND SUBTRACTION OF NON-MODEL NEAR MIN AND + -- MAX: + IF MIN + NON_MODEL_VAR NOT IN -999.5 .. -999.25 OR + NON_MODEL_CONST + F'FIRST NOT IN -999.5 .. -999.25 THEN + FAILED ("-1000.0 + (2.0 / 3) NOT IN -999.5 .. -999.25"); + END IF; + IF MAX - NON_MODEL_VAR NOT IN 999.25 .. 999.5 OR + F'LAST - NON_MODEL_CONST NOT IN 999.25 .. 999.5 THEN + FAILED ("1000.0 - (2.0 / 3) NOT IN 999.25 .. 999.5"); + END IF; + + -- CHECK ADDITION AND SUBTRACTION FOR ARBITRARY MID-RANGE + -- MODEL NUMBER WITH NON-MODEL: + IF EQUAL (3, 3) THEN + X := -213.25; + END IF; + IF X + NON_MODEL_CONST NOT IN -212.75 .. -212.5 THEN + FAILED ("-213.25 + (2.0 / 3) NOT IN -212.75 .. -212.5"); + END IF; + IF NON_MODEL_VAR - X NOT IN 213.75 .. 214.0 THEN + FAILED ("(2.0 / 3) - (-213.25) NOT IN 213.75 .. 214.0"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - B"); + END B; + + ------------------------------------------------------------------- + +C: DECLARE + A_SMALL, A_MAX, A_MIN : ST_F1 := 0.0; + B_SMALL, B_MAX, B_MIN : ST_F2 := 0.0; + X : F; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + A_SMALL := ST_F1'SMALL; + A_MAX := ST_F1'LAST; -- BECAUSE 'LAST < 'LARGE AND + -- 'LAST IS A MODEL NUMBER. + A_MIN := ST_F1'FIRST; -- 'FIRST IS A MODEL NUMBER. + + B_SMALL := ST_F2'SMALL; + B_MAX := ST_F2'LAST; -- BECAUSE 'LAST <= 'LARGE AND + -- 'LAST IS A MODEL NUMBER. + B_MIN := ST_F2'FIRST; -- 'FIRST IS A MODEL NUMBER. + END IF; + + IF A_MIN + B_MIN /= -4.8125 THEN + FAILED ("-4.0 + (-0.8125) /= -4.8125"); + END IF; + + IF A_MIN - B_MIN /= -3.1875 THEN + FAILED ("-4.0 - (-0.8125) /= -3.1875"); + END IF; + + IF (A_MIN + B_SMALL) NOT IN A_MIN .. -3.9375 THEN + FAILED ("(A_MIN + B_SMALL) NOT IN A_MIN .. -3.9375"); + END IF; + + IF (A_MIN - B_SMALL) NOT IN -4.0625 .. -4.0 THEN + FAILED ("(A_MIN - B_SMALL) NOT IN -4.0 .. -4.0625"); + END IF; + + IF A_MIN + B_MAX /= 1.0625 THEN + FAILED ("-4.0 + 5.0625 /= 1.0625"); + END IF; + + IF A_MIN - B_MAX /= -9.0625 THEN + FAILED ("-4.0 - 5.0625 /= -9.0625"); + END IF; + + IF (A_SMALL + B_MIN) NOT IN B_MIN..-0.3125 THEN + FAILED ("(A_SMALL + B_MIN) NOT IN B_MIN..-0.3125"); + END IF; + + IF (A_SMALL - B_MIN) NOT IN +0.8125 .. 1.3125 THEN + FAILED ("(A_SMALL - B_MIN) NOT IN -0.8125 .. 1.3125"); + END IF; + + + + IF (A_SMALL + B_MAX) NOT IN 5.0625 .. 5.5625 THEN + FAILED ("(A_SMALL + B_MAX) NOT IN 5.0625 .. 5.5625"); + END IF; + + IF (A_SMALL - B_MAX) NOT IN -5.0625 .. -4.5625 THEN + FAILED ("(A_SMALL - B_MAX) NOT IN -5.0625 .. -4.5625"); + END IF; + + IF A_MAX + B_MIN /= 2.1875 THEN + FAILED ("3.0 + (-0.8125) /= 2.1875"); + END IF; + + IF A_MAX - B_MIN /= 3.8125 THEN + FAILED ("3.0 - (-0.8125) /= 3.8125"); + END IF; + + IF (A_MAX + B_SMALL) NOT IN 3.0 .. 3.0625 THEN + FAILED ("(A_MAX + B_SMALL) NOT IN 3.0 .. 3.0625"); + END IF; + + IF (A_MAX - B_SMALL) NOT IN 2.9375..3.0 THEN + FAILED ("(A_MAX - B_SMALL) NOT IN 2.9375..3.0"); + END IF; + + IF A_MAX + B_MAX /= 8.0625 THEN + FAILED ("3.0 + 5.0625 /= 8.0625"); + END IF; + + IF A_MAX - B_MAX /= -2.0625 THEN + FAILED ("3.0 - 5.0625 /= -2.0625"); + END IF; + + X := B_MIN - A_MIN; + IF X NOT IN 3.0 .. 3.25 THEN + FAILED ("-0.8125 - (-4.0) NOT IN RANGE"); + END IF; + + X := B_MIN - A_SMALL; + IF X NOT IN -1.3125 .. -0.8125 THEN + FAILED ("B_MIN - A_SMALL NOT IN RANGE"); + END IF; + + X := B_MIN - A_MAX; + IF X NOT IN -4.0 .. -3.75 THEN + FAILED ("-0.8125 - 3.0 NOT IN RANGE"); + END IF; + + X := B_SMALL - A_MIN; + IF X NOT IN 4.0 .. 4.0625 THEN + FAILED ("B_SMALL - A_MIN NOT IN RANGE"); + END IF; + + + X := B_SMALL - A_MAX; + IF X NOT IN -3.0 .. -2.75 THEN + FAILED ("B_SMALL - A_MAX NOT IN RANGE"); + END IF; + + X := B_MAX - A_MIN; + IF X NOT IN 9.0 .. 9.25 THEN + FAILED ("5.0625 - (-4.0) NOT IN RANGE"); + END IF; + + X := B_MAX - A_SMALL; + IF X NOT IN 4.56 .. 5.0625 THEN + FAILED ("5.0625 - 0.5 NOT IN RANGE"); + END IF; + + X := B_MAX - A_MAX; + IF X NOT IN 2.0 .. 2.25 THEN + FAILED ("5.0625 - 3.0 NOT IN RANGE"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - C"); + END C; + + ------------------------------------------------------------------- + + RESULT; + +END C45331A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45342a.ada b/gcc/testsuite/ada/acats/tests/c4/c45342a.ada new file mode 100644 index 000000000..73a05290a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45342a.ada @@ -0,0 +1,99 @@ +-- C45342A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CATENATION OF TWO OR MORE NON-NULL OPERANDS YIELDS THE +-- CORRECT RESULT, WITH THE CORRECT BOUNDS, WHETHER BOUNDS ARE STATIC OR +-- DYNAMIC. + +-- BHS 6/27/84 + +WITH REPORT; +PROCEDURE C45342A IS + + USE REPORT; + + SUBTYPE S IS INTEGER RANGE 1..100; + TYPE ARR IS ARRAY (S RANGE <>) OF INTEGER; + + A,B : ARR (2..9); + + FUNCTION F (AR_VAR1, AR_VAR2, AR_VAR3 : ARR) RETURN ARR IS + BEGIN + RETURN AR_VAR1 & AR_VAR2 & AR_VAR3; + END F; + + PROCEDURE CAT (A : ARR; I1,I2 : INTEGER; NUM : CHARACTER) IS + BEGIN + IF A'FIRST /= I1 OR A'LAST /= I2 THEN + FAILED ("INCORRECT CATENATION BOUNDS - " & NUM); + END IF; + END CAT; + + +BEGIN + + TEST ("C45342A", "CHECK THAT CATENATION OF NON-NULL OPERANDS " & + "YIELDS CORRECT RESULT WITH CORRECT BOUNDS"); + + BEGIN + A := (1,2,3,4,5,6,7,8); + B := A(2..4) & A(2..5) & A(2..2); + IF B /= (1,2,3,1,2,3,4,1) THEN + FAILED ("INCORRECT CATENATION RESULT - 1"); + END IF; + + A := (8,7,6,5,4,3,2,1); + IF F(A(2..3), A(2..4), A(2..4)) /= (8,7,8,7,6,8,7,6) THEN + FAILED ("INCORRECT CATENATION RESULT - 2"); + END IF; + + CAT ( A(3..5) & A(2..3), 3, 7, '3' ); + END; + + + DECLARE + DYN2 : INTEGER := IDENT_INT(2); + DYN3 : INTEGER := IDENT_INT(3); + DYN4 : INTEGER := IDENT_INT(4); + DYN6 : INTEGER := IDENT_INT(6); + + BEGIN + A := (1,2,3,4,5,6,7,8); + B := A(DYN2..DYN3) & A(DYN2..DYN4) & A(DYN2..DYN4); + IF B /= (1,2,1,2,3,1,2,3) THEN + FAILED ("INCORRECT CATENATION RESULT - 4"); + END IF; + + A := (8,7,6,5,4,3,2,1); + IF F ( A(DYN2..DYN6), A(DYN2..DYN3), A(DYN2..DYN2) ) + /= (8,7,6,5,4,8,7,8) THEN + FAILED ("INCORRECT CATENATION RESULT - 5"); + END IF; + + CAT ( A(DYN3..5) & A(2..3), 3, 7, '6'); + END; + + RESULT; + +END C45342A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45343a.ada b/gcc/testsuite/ada/acats/tests/c4/c45343a.ada new file mode 100644 index 000000000..a99db7f28 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45343a.ada @@ -0,0 +1,75 @@ +-- C45343A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CATENATION OF NULL OPERANDS YIELDS THE CORRECT RESULT, +-- WITH THE CORRECT BOUNDS. + +-- BHS 6/29/84 + +WITH REPORT; +PROCEDURE C45343A IS + + USE REPORT; + + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE ARR_8 IS ARR (1..8); + A1, A2 : ARR_8; + + PROCEDURE CAT (A : ARR; I1,I2 : INTEGER; NUM : CHARACTER) IS + BEGIN + IF A'FIRST /= I1 OR A'LAST /= I2 THEN + FAILED ("INCORRECT CATENATION - " & NUM); + END IF; + END CAT; + +BEGIN + + TEST ("C45343A", "CATENATION OF NULL OPERANDS"); + + + A1 := (1,2,3,4,5,6,7,8); + A2 := A1(1..0) & A1(6..5) & A1(1..8); + IF A2 /= (1,2,3,4,5,6,7,8) THEN + FAILED ("INCORRECT CATENATION RESULT - 1"); + END IF; + + A1 := (1,2,3,4,5,6,7,8); + A2 := A1(2..8) & A1(1..0) & 9; + IF A2 /= (2,3,4,5,6,7,8,9) THEN + FAILED ("INCORRECT CATENATION RESULT - 2"); + END IF; + + + CAT ( A1(1..0) & A1(IDENT_INT(2)..0), 2, 0, '3' ); + CAT ( A1(IDENT_INT(1)..0) & A2(2..0), 2, 0, '4' ); + + CAT ( A1(1..0) & A1(6..5) & A1(2..8), 2, 8, '5' ); + CAT ( A1(2..8) & A1(1..0), 2, 8, '6' ); + + CAT ( A2(1..0) & A2(6..5) & A2(IDENT_INT(2)..8), 2, 8, '7' ); + CAT ( A2(IDENT_INT(2)..8) & A2(1..0), 2, 8, '8' ); + + RESULT; + +END C45343A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45344a.ada b/gcc/testsuite/ada/acats/tests/c4/c45344a.ada new file mode 100644 index 000000000..b75f2a7ef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45344a.ada @@ -0,0 +1,116 @@ +-- C45344A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE CORRECT RESULT IS PRODUCED WHEN A FUNCTION RETURNS +-- THE RESULT OF A CATENATION WHOSE BOUNDS ARE NOT DEFINED STATICALLY. + +-- R.WILLIAMS 9/1/86 + +WITH REPORT; USE REPORT; +PROCEDURE C45344A IS + +BEGIN + TEST ( "C45344A", "CHECK THAT THE CORRECT RESULT IS PRODUCED " & + "WHEN A FUNCTION RETURNS THE RESULT OF A " & + "CATENATION WHOSE BOUNDS ARE NOT DEFINED " & + "STATICALLY" ); + + DECLARE + SUBTYPE INT IS INTEGER RANGE IDENT_INT (1) .. IDENT_INT (30); + + TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER; + SUBTYPE CARR IS ARR (1 .. 9); + C : CARR; + + AR1 : ARR (IDENT_INT (2) .. IDENT_INT (4)) := + (IDENT_INT (2) .. IDENT_INT (4) => 1); + + AR2 : ARR (IDENT_INT (6) .. IDENT_INT (6)) := + (IDENT_INT (6) .. IDENT_INT (6) => 2); + + AR3 : ARR (IDENT_INT (4) .. IDENT_INT (2)); + + FUNCTION F (A, B : ARR; N : NATURAL) RETURN ARR IS + BEGIN + IF N = 0 THEN + RETURN A & B; + ELSE + RETURN F (A & B, B, N - 1); + END IF; + END F; + + FUNCTION G (A : INTEGER; B : ARR; N : NATURAL) RETURN ARR IS + BEGIN + IF N = 0 THEN + RETURN A & B; + ELSE + RETURN G (A, A & B, N - 1); + END IF; + END G; + + FUNCTION H (A : ARR; B : INTEGER; N : NATURAL) RETURN ARR IS + BEGIN + IF N = 0 THEN + RETURN A & B; + ELSE + RETURN H (A & B, B, N - 1); + END IF; + END H; + + PROCEDURE CHECK (X, Y : ARR; F, L : INTEGER; STR : STRING) IS + OK : BOOLEAN := TRUE; + BEGIN + IF X'FIRST /= F AND X'LAST /= L THEN + FAILED ( "INCORRECT RANGE FOR " & STR); + ELSE + FOR I IN F .. L LOOP + IF X (I) /= Y (I) THEN + OK := FALSE; + END IF; + END LOOP; + + IF NOT OK THEN + FAILED ( "INCORRECT VALUE FOR " & STR); + END IF; + END IF; + END CHECK; + + BEGIN + C := (1 .. 4 => 1, 5 .. 9 => 2); + CHECK (F (AR1, AR2, IDENT_INT (3)), C, 2, 8, "F - 1" ); + CHECK (F (AR3, AR2, IDENT_INT (3)), C, 6, 9, "F - 2" ); + CHECK (F (AR2, AR3, IDENT_INT (3)), C, 6, 6, "F - 3" ); + + C := (1 ..4 => 5, 5 .. 9 => 1); + CHECK (G (5, AR1, IDENT_INT (3)), C, 1, 7, "G - 1" ); + CHECK (G (5, AR3, IDENT_INT (3)), C, 1, 4, "G - 2" ); + + CHECK (H (AR3, 5, IDENT_INT (3)), C, 1, 4, "H - 1" ); + + C := (1 ..4 => 1, 5 .. 9 => 5); + CHECK (H (AR1, 5, IDENT_INT (3)), C, 2, 8, "H - 2" ); + END; + + RESULT; +END C45344A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45345b.ada b/gcc/testsuite/ada/acats/tests/c4/c45345b.ada new file mode 100644 index 000000000..e4b31ec59 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45345b.ada @@ -0,0 +1,118 @@ +-- C45345B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF THE RESULT OF +-- CATENATION HAS PRECISELY THE MAXIMUM LENGTH PERMITTED BY THE +-- INDEX SUBTYPE. + + +-- RM 2/26/82 + + +WITH REPORT; +USE REPORT; +PROCEDURE C45345B IS + + +BEGIN + + TEST ( "C45345B" , "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED" & + " IF THE RESULT OF CATENATION HAS PRECISELY" & + " THE MAXIMUM LENGTH PERMITTED BY THE" & + " INDEX SUBTYPE" ); + + + ------------------------------------------------------------------- + ----------------- STRG_VAR := STRG_LIT & STRG_LIT --------------- + + DECLARE + + X : STRING(1..5) ; + + BEGIN + + X := "ABCD" & "E" ; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED( "'STRING & STRING' RAISED CONSTRAINT_ERROR " ); + + WHEN OTHERS => + FAILED( "'STRING & STRING' RAISED ANOTHER EXCEPTION" ); + + END; + + + ------------------------------------------------------------------- + ----------------- STRG_VAR := STRG_LIT & CHARACTER -------------- + + DECLARE + + X : STRING(1..5) ; + + BEGIN + + X := "ABCD" & 'E' ; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED( "'STRING & STRING' RAISED CONSTRAINT_ERROR " ); + + WHEN OTHERS => + FAILED( "'STRING & STRING' RAISED ANOTHER EXCEPTION" ); + + END; + + ------------------------------------------------------------------- + ----------------- STRG_VAR := STRG_VAR & STRG_VAR --------------- + + DECLARE + + X : STRING(1..5) ; + A : CONSTANT STRING := "A" ; + B : STRING(1..4) := IDENT_STR("BCDE") ; + + BEGIN + + X := A & B ; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED( "'STRING & STRING' RAISED CONSTRAINT_ERROR " ); + + WHEN OTHERS => + FAILED( "'STRING & STRING' RAISED ANOTHER EXCEPTION" ); + + END; + + ------------------------------------------------------------------- + + + RESULT; + + +END C45345B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45347a.ada b/gcc/testsuite/ada/acats/tests/c4/c45347a.ada new file mode 100644 index 000000000..a93ae875e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45347a.ada @@ -0,0 +1,96 @@ +-- C45347A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CATENATION IS DEFINED FOR RECORD TYPES AS COMPONENT TYPES. + +-- JWC 11/15/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C45347A IS + +BEGIN + + TEST ("C45347A", "CHECK THAT CATENATION IS DEFINED " & + "FOR RECORD TYPES AS COMPONENT TYPES"); + + DECLARE + + TYPE REC IS + RECORD + X : INTEGER; + END RECORD; + + SUBTYPE INT IS INTEGER RANGE 1 .. 4; + TYPE A IS ARRAY ( INT RANGE <>) OF REC; + + R1 : REC := (X => 4); + R2 : REC := (X => 1); + + A1 : A(1 .. 2) := ((X => 1), (X => 2)); + A2 : A(1 .. 2) := ((X => 3), (X => 4)); + A3 : A(1 .. 4) := ((X => 1), (X => 2), (X => 3), (X => 4)); + A4 : A(1 .. 4); + A5 : A(1 .. 4) := ((X => 4), (X => 3), (X => 2), (X => 1)); + + BEGIN + + A4 := A1 & A2; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR TWO ARRAYS OF " & + "RECORDS"); + END IF; + + A4 := A5; + + A4 := A1 & A2(1) & R1; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAY OF RECORD, " & + "AND RECORDS"); + END IF; + + A4 := A5; + + A4 := R2 & (A1(2) & A2); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR RECORDS, " & + "AND ARRAY OF RECORDS"); + END IF; + + A4 := A5; + + A4 := R2 & A1(2) & (A2(1) & R1); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR RECORDS"); + END IF; + + END; + + RESULT; + +END C45347A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45347b.ada b/gcc/testsuite/ada/acats/tests/c4/c45347b.ada new file mode 100644 index 000000000..220100b39 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45347b.ada @@ -0,0 +1,90 @@ +-- C45347B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CATENATION IS DEFINED FOR ARRAY TYPES AS COMPONENT TYPES. + +-- JWC 11/15/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C45347B IS + +BEGIN + + TEST ("C45347B", "CHECK THAT CATENATION IS DEFINED " & + "FOR ARRAY TYPES AS COMPONENT TYPES"); + + DECLARE + + TYPE ARR IS ARRAY (1 .. 2) OF INTEGER; + TYPE A IS ARRAY ( INTEGER RANGE <>) OF ARR; + + AR1 : ARR := (4,1); + AR2 : ARR := (1,1); + + A1 : A(1 .. 2) := ((1,1), (2,1)); + A2 : A(1 .. 2) := ((3,1), (4,1)); + A3 : A(1 .. 4) := ((1,1), (2,1), (3,1), (4,1)); + A4 : A(1 .. 4); + A5 : A(1 .. 4) := ((4,1), (3,1), (2,1), (1,1)); + + BEGIN + + A4 := A1 & A2; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAYS OF ARRAYS"); + END IF; + + A4 := A5; + + A4 := A1 & A2(1) & AR1; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAY OF ARRAYS " & + "WITH ARRAYS"); + END IF; + + A4 := A5; + + A4 := AR2 & (A1(2) & A2); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAYS WITH ARRAYS " & + "OF ARRAYS"); + END IF; + + A4 := A5; + + A4 := A'(AR2 & A1(2)) & A'(A2(1) & AR1); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAYS"); + END IF; + + END; + + RESULT; + +END C45347B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45347c.ada b/gcc/testsuite/ada/acats/tests/c4/c45347c.ada new file mode 100644 index 000000000..0ad23a7a6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45347c.ada @@ -0,0 +1,108 @@ +-- C45347C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CATENATION IS DEFINED FOR PRIVATE TYPES AS COMPONENT +-- TYPES. + +-- JWC 11/15/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C45347C IS + +BEGIN + + TEST ("C45347C", "CHECK THAT CATENATION IS DEFINED " & + "FOR PRIVATE TYPES AS COMPONENT TYPES"); + + DECLARE + + PACKAGE PKG IS + TYPE PRIV IS PRIVATE; + ONE : CONSTANT PRIV; + TWO : CONSTANT PRIV; + THREE : CONSTANT PRIV; + FOUR : CONSTANT PRIV; + PRIVATE + TYPE PRIV IS NEW INTEGER; + ONE : CONSTANT PRIV := 1; + TWO : CONSTANT PRIV := 2; + THREE : CONSTANT PRIV := 3; + FOUR : CONSTANT PRIV := 4; + END PKG; + + USE PKG; + + SUBTYPE INT IS INTEGER RANGE 1 .. 4; + TYPE A IS ARRAY ( INT RANGE <>) OF PRIV; + + P1 : PRIV := FOUR; + P2 : PRIV := ONE; + + A1 : A(1 .. 2) := (ONE, TWO); + A2 : A(1 .. 2) := (THREE, FOUR); + A3 : A(1 .. 4) := (ONE, TWO, THREE, FOUR); + A4 : A(1 .. 4); + A5 : A(1 .. 4) := (FOUR, THREE, TWO, ONE); + + BEGIN + + A4 := A1 & A2; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR TWO ARRAYS OF " & + "PRIVATE"); + END IF; + + A4 := A5; + + A4 := A1 & A2(1) & P1; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAY OF PRIVATE, " & + "AND PRIVATE"); + END IF; + + A4 := A5; + + A4 := P2 & (A1(2) & A2); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR PRIVATE, AND ARRAY " & + "OF PRIVATE"); + END IF; + + A4 := A5; + + A4 := P2 & A1(2) & (A2(1) & P1); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR PRIVATE"); + END IF; + + END; + + RESULT; + +END C45347C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45347d.ada b/gcc/testsuite/ada/acats/tests/c4/c45347d.ada new file mode 100644 index 000000000..0791be10f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45347d.ada @@ -0,0 +1,93 @@ +-- C45347D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CATENATION IS DEFINED FOR ACCESS TYPES AS COMPONENT TYPES. + +-- JWC 11/15/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C45347D IS + +BEGIN + + TEST ("C45347D", "CHECK THAT CATENATION IS DEFINED " & + "FOR ACCESS TYPES AS COMPONENT TYPES"); + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1 .. 4; + TYPE ACC IS ACCESS INT; + TYPE A IS ARRAY ( INT RANGE <>) OF ACC; + + AC1 : ACC := NEW INT'(1); + AC2 : ACC := NEW INT'(2); + AC3 : ACC := NEW INT'(3); + AC4 : ACC := NEW INT'(4); + + A1 : A(1 .. 2) := (AC1, AC2); + A2 : A(1 .. 2) := (AC3, AC4); + A3 : A(1 .. 4) := (AC1, AC2, AC3, AC4); + A4 : A(1 .. 4); + A5 : A(1 .. 4) := (AC4, AC3, AC2, AC1); + + BEGIN + + A4 := A1 & A2; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR TWO ARRAYS OF ACCESS"); + END IF; + + A4 := A5; + + A4 := A1 & A2(1) & AC4; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAY OF ACCESS, " & + "AND ACCESS"); + END IF; + + A4 := A5; + + A4 := AC1 & (A1(2) & A2); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ACCESS, AND ARRAY " & + "OF ACCESS"); + END IF; + + A4 := A5; + + A4 := AC1 & A1(2) & (A2(1) & AC4); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ACCESS"); + END IF; + + END; + + RESULT; + +END C45347D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45411a.ada b/gcc/testsuite/ada/acats/tests/c4/c45411a.ada new file mode 100644 index 000000000..0ac3b10a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45411a.ada @@ -0,0 +1,120 @@ +-- C45411A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT UNARY "+" AND "-" YIELD CORRECT RESULTS FOR +-- PREDEFINED INTEGER OPERANDS. + +-- HISTORY: +-- JET 01/25/88 CREATED ORIGINAL TEST. +-- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS. + +WITH REPORT; USE REPORT; + +PROCEDURE C45411A IS + + TYPE DT IS NEW INTEGER RANGE -3..3; + I1 : INTEGER := 1; + D1 : DT := 1; + +BEGIN + TEST ("C45411A", "CHECK THAT UNARY ""+"" AND ""-"" YIELD " & + "CORRECT RESULTS FOR PREDEFINED INTEGER " & + "OPERANDS"); + + FOR I IN (1-2)..INTEGER(1) LOOP + IF "-"(RIGHT => I1) /= IDENT_INT(I) THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + INTEGER'IMAGE(I+2)); + END IF; + + IF +I1 /= IDENT_INT(I1) THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + INTEGER'IMAGE(I+2)); + END IF; + I1 := I1 - 1; + END LOOP; + + FOR I IN (1-2)..INTEGER(1) LOOP + IF -I /= IDENT_INT(0)-I THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + INTEGER'IMAGE(I+5)); + END IF; + + IF "+"(RIGHT => IDENT_INT(I)) /= I THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + INTEGER'IMAGE(I+5)); + END IF; + END LOOP; + + IF -1 /= IDENT_INT(1)-2 THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 7"); + END IF; + + IF "-"(RIGHT => 0) /= IDENT_INT(0) THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 8"); + END IF; + + IF "-"(RIGHT => "-"(RIGHT => 1)) /= IDENT_INT(1) THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 9"); + END IF; + + IF "+"(RIGHT => 1) /= IDENT_INT(2)-1 THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 7"); + END IF; + + IF +0 /= IDENT_INT(0) THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 8"); + END IF; + + IF +(-1) /= IDENT_INT(1)-2 THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 9"); + END IF; + + FOR I IN (1-2)..INTEGER(1) LOOP + IF "-"(RIGHT => D1) /= DT(IDENT_INT(I)) THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + INTEGER'IMAGE(I+11)); + END IF; + + IF +D1 /= DT(IDENT_INT(INTEGER(D1))) THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + INTEGER'IMAGE(I+11)); + END IF; + D1 := D1 - 1; + END LOOP; + + IF INTEGER'LAST + INTEGER'FIRST = 0 THEN + IF IDENT_INT(-INTEGER'LAST) /= INTEGER'FIRST THEN + FAILED ("-INTEGER'LAST IS NOT EQUAL TO INTEGER'FIRST"); + END IF; + ELSE + IF IDENT_INT(-INTEGER'LAST) /= INTEGER'FIRST+1 THEN + FAILED ("-INTEGER'LAST IS NOT EQUAL TO INTEGER'FIRST+1"); + END IF; + END IF; + + RESULT; + +END C45411A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45411b.dep b/gcc/testsuite/ada/acats/tests/c4/c45411b.dep new file mode 100644 index 000000000..faae4b1f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45411b.dep @@ -0,0 +1,123 @@ +-- C45411B.DEP + +-- 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 UNARY "+" AND "-" YIELD CORRECT RESULTS FOR +-- PREDEFINED SHORT_INTEGER OPERANDS. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT +-- THE PREDEFINED SHORT_INTEGER TYPE. + +-- IF THE TYPE SHORT_INTEGER IS NOT SUPPORTED, THEN THE DECLARATION +-- OF TYPE "DT" MUST BE REJECTED. + +-- HISTORY: +-- JET 07/11/88 CREATED ORIGINAL TEST. +-- KAS 01/12/95 DELETED INCOMPATIBLE SUBTEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C45411B IS + + TYPE DT IS NEW SHORT_INTEGER RANGE -3..3; -- N/A => ERROR. + I1 : SHORT_INTEGER := 1; + D1 : DT := 1; + + FUNCTION IDENT (A : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN A * SHORT_INTEGER(IDENT_INT(1)); + END; + +BEGIN + TEST ("C45411B", "CHECK THAT UNARY ""+"" AND ""-"" YIELD " & + "CORRECT RESULTS FOR PREDEFINED SHORT_INTEGER " & + "OPERANDS"); + + FOR I IN (1-2)..SHORT_INTEGER(1) LOOP + IF "-"(RIGHT => I1) /= IDENT(I) THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + SHORT_INTEGER'IMAGE(I+2)); + END IF; + + IF +I1 /= IDENT(I1) THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + SHORT_INTEGER'IMAGE(I+2)); + END IF; + I1 := I1 - 1; + END LOOP; + + FOR I IN (1-2)..SHORT_INTEGER(1) LOOP + IF -I /= IDENT(0)-I THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + SHORT_INTEGER'IMAGE(I+5)); + END IF; + + IF "+"(RIGHT => IDENT(I)) /= I THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + SHORT_INTEGER'IMAGE(I+5)); + END IF; + END LOOP; + + IF -1 /= IDENT(1)-2 THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 7"); + END IF; + + IF "-"(RIGHT => 0) /= IDENT(0) THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 8"); + END IF; + + IF "-"(RIGHT => "-"(RIGHT => 1)) /= IDENT(1) THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 9"); + END IF; + + IF "+"(RIGHT => 1) /= IDENT(2)-1 THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 7"); + END IF; + + IF +0 /= IDENT(0) THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 8"); + END IF; + + IF +(-1) /= IDENT(1)-2 THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 9"); + END IF; + + FOR I IN (1-2)..SHORT_INTEGER(1) LOOP + IF "-"(RIGHT => D1) /= DT(IDENT(I)) THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + SHORT_INTEGER'IMAGE(I+11)); + END IF; + + IF +D1 /= DT(IDENT(SHORT_INTEGER(D1))) THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + SHORT_INTEGER'IMAGE(I+11)); + END IF; + D1 := D1 - 1; + END LOOP; + + + RESULT; + +END C45411B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45411c.dep b/gcc/testsuite/ada/acats/tests/c4/c45411c.dep new file mode 100644 index 000000000..eaa472362 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45411c.dep @@ -0,0 +1,123 @@ +-- C45411C.DEP + +-- 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 UNARY "+" AND "-" YIELD CORRECT RESULTS FOR +-- PREDEFINED LONG_INTEGER OPERANDS. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT +-- THE PREDEFINED LONG_INTEGER TYPE. + +-- IF THE TYPE LONG_INTEGER IS NOT SUPPORTED, THEN THE DECLARATION +-- OF TYPE "DT" MUST BE REJECTED. + +-- HISTORY: +-- JET 07/11/88 CREATED ORIGINAL TEST. +-- KAS 01/12/95 REMOVED INCOMPATIBLE SUBTEST + +WITH REPORT; USE REPORT; + +PROCEDURE C45411C IS + + TYPE DT IS NEW LONG_INTEGER RANGE -3..3; -- N/A => ERROR. + I1 : LONG_INTEGER := 1; + D1 : DT := 1; + + FUNCTION IDENT (A : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + RETURN A * LONG_INTEGER(IDENT_INT(1)); + END; + +BEGIN + TEST ("C45411C", "CHECK THAT UNARY ""+"" AND ""-"" YIELD " & + "CORRECT RESULTS FOR PREDEFINED LONG_INTEGER " & + "OPERANDS"); + + FOR I IN (1-2)..LONG_INTEGER(1) LOOP + IF "-"(RIGHT => I1) /= IDENT(I) THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + LONG_INTEGER'IMAGE(I+2)); + END IF; + + IF +I1 /= IDENT(I1) THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + LONG_INTEGER'IMAGE(I+2)); + END IF; + I1 := I1 - 1; + END LOOP; + + FOR I IN (1-2)..LONG_INTEGER(1) LOOP + IF -I /= IDENT(0)-I THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + LONG_INTEGER'IMAGE(I+5)); + END IF; + + IF "+"(RIGHT => IDENT(I)) /= I THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + LONG_INTEGER'IMAGE(I+5)); + END IF; + END LOOP; + + IF -1 /= IDENT(1)-2 THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 7"); + END IF; + + IF "-"(RIGHT => 0) /= IDENT(0) THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 8"); + END IF; + + IF "-"(RIGHT => "-"(RIGHT => 1)) /= IDENT(1) THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 9"); + END IF; + + IF "+"(RIGHT => 1) /= IDENT(2)-1 THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 7"); + END IF; + + IF +0 /= IDENT(0) THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 8"); + END IF; + + IF +(-1) /= IDENT(1)-2 THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 9"); + END IF; + + FOR I IN (1-2)..LONG_INTEGER(1) LOOP + IF "-"(RIGHT => D1) /= DT(IDENT(I)) THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + LONG_INTEGER'IMAGE(I+11)); + END IF; + + IF +D1 /= DT(IDENT(LONG_INTEGER(D1))) THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + LONG_INTEGER'IMAGE(I+11)); + END IF; + D1 := D1 - 1; + END LOOP; + + + RESULT; + +END C45411C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45411d.ada b/gcc/testsuite/ada/acats/tests/c4/c45411d.ada new file mode 100644 index 000000000..23adcbdc6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45411d.ada @@ -0,0 +1,98 @@ +-- C45411D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT UNARY "+" AND "-" YIELD CORRECT RESULTS FOR +-- OPERANDS OF DERIVED INTEGER TYPES. + +-- HISTORY: +-- JET 07/11/88 CREATED ORIGINAL TEST. +-- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS. + +WITH REPORT; USE REPORT; + +PROCEDURE C45411D IS + + TYPE INT IS RANGE -100..100; + + TYPE DT1 IS NEW INTEGER; + TYPE DT2 IS NEW INT; + + D1 : DT1 := 1; + D2 : DT2 := 1; + + FUNCTION IDENT (A : DT1) RETURN DT1 IS + BEGIN + RETURN A * DT1(IDENT_INT(1)); + END IDENT; + + FUNCTION IDENT (A : DT2) RETURN DT2 IS + BEGIN + RETURN A * DT2(IDENT_INT(1)); + END IDENT; + +BEGIN + TEST ("C45411D", "CHECK THAT UNARY ""+"" AND ""-"" YIELD " & + "CORRECT RESULTS FOR OPERANDS OF DERIVED " & + "INTEGER TYPES"); + + FOR I IN DT1'(1-2)..DT1'(1) LOOP + IF "-"(RIGHT => D1) /= IDENT(I) THEN + FAILED ("INCORRECT RESULT FOR ""-"" DT1 -" & + DT1'IMAGE(I+2)); + END IF; + + IF +D1 /= IDENT(D1) THEN + FAILED ("INCORRECT RESULT FOR ""+"" DT1 -" & + DT1'IMAGE(I+2)); + END IF; + D1 := D1 - 1; + END LOOP; + + IF DT1'LAST + DT1'FIRST = 0 THEN + IF IDENT(-DT1'LAST) /= DT1'FIRST THEN + FAILED ("-DT1'LAST IS NOT EQUAL TO DT1'FIRST"); + END IF; + ELSE + IF IDENT(-DT1'LAST) /= DT1'FIRST+1 THEN + FAILED ("-DT1'LAST IS NOT EQUAL TO DT1'FIRST+1"); + END IF; + END IF; + + FOR I IN DT2'(1-2)..DT2'(1) LOOP + IF -D2 /= IDENT(I) THEN + FAILED ("INCORRECT RESULT FOR ""-"" DT2 -" & + DT2'IMAGE(I+2)); + END IF; + + IF "+"(RIGHT => D2) /= IDENT(D2) THEN + FAILED ("INCORRECT RESULT FOR ""+"" DT2 -" & + DT2'IMAGE(I+2)); + END IF; + D2 := D2 - 1; + END LOOP; + + RESULT; + +END C45411D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45413a.ada b/gcc/testsuite/ada/acats/tests/c4/c45413a.ada new file mode 100644 index 000000000..46833238f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45413a.ada @@ -0,0 +1,74 @@ +-- C45413A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT UNARY MINUS YIELDS AND ACCEPTS RESULTS BELONGING TO +-- THE BASE TYPE. + +-- JBG 2/24/84 +-- JRL 10/13/96 Removed static expressions which contained values outside +-- the base range. + +WITH REPORT; USE REPORT; +PROCEDURE C45413A IS + + TYPE INT IS RANGE 1..10; + + X : INT := INT(IDENT_INT(9)); + +BEGIN + + TEST ("C45413A", "CHECK SUBTYPE OF UNARY PLUS/MINUS"); + + BEGIN + + IF -X /= INT'VAL(-9) THEN + FAILED ("INCORRECT RESULT - UNARY MINUS"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("UNARY MINUS DOES NOT YIELD RESULT " & + "BELONGING TO THE BASE TYPE"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 1"); + END; + + BEGIN + + IF -(INT'VAL(-9)) /= 9 THEN + FAILED ("WRONG RESULT - UNARY MINUS"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("UNARY MINUS ARGUMENT NOT IN BASE TYPE"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 2"); + END; + + RESULT; + +END C45413A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45431a.ada b/gcc/testsuite/ada/acats/tests/c4/c45431a.ada new file mode 100644 index 000000000..d66e890fc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45431a.ada @@ -0,0 +1,212 @@ +-- C45431A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR FIXED POINT TYPES +A = A AND THAT, FOR MODEL NUMBERS, +-- -(-A) = A. + +-- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE. + +-- WRG 8/28/86 +-- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE C45431A IS + +BEGIN + + TEST ("C45431A", "CHECK THAT FOR FIXED POINT TYPES +A = A AND " & + "THAT, FOR MODEL NUMBERS, -(-A) = A " & + "-- BASIC TYPES"); + + ------------------------------------------------------------------- + +A: DECLARE + TYPE LIKE_DURATION IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + + NON_MODEL_CONST : CONSTANT := 2.0 / 3; + NON_MODEL_VAR : LIKE_DURATION := 0.0; + + SMALL, MAX, MIN, ZERO : LIKE_DURATION := 0.5; + X : LIKE_DURATION := 0.0; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + NON_MODEL_VAR := NON_MODEL_CONST; + SMALL := LIKE_DURATION'SMALL; + MAX := LIKE_DURATION'LAST; + MIN := LIKE_DURATION'FIRST; + ZERO := 0.0; + END IF; + + -- CHECK + OR - ZERO = ZERO: + IF "+"(RIGHT => ZERO) /= 0.0 OR + +LIKE_DURATION'(0.0) /= ZERO THEN + FAILED ("+0.0 /= 0.0"); + END IF; + IF "-"(RIGHT => ZERO) /= 0.0 OR + -LIKE_DURATION'(0.0) /= ZERO THEN + FAILED ("-0.0 /= 0.0"); + END IF; + IF -(-ZERO) /= 0.0 THEN + FAILED ("-(-0.0) /= 0.0"); + END IF; + + -- CHECK + AND - MAX: + IF EQUAL (3, 3) THEN + X := MAX; + END IF; + IF +X /= MAX OR +LIKE_DURATION'LAST /= MAX THEN + FAILED ("+LIKE_DURATION'LAST /= LIKE_DURATION'LAST"); + END IF; + IF -(-X) /= MAX OR -(-LIKE_DURATION'LAST) /= MAX THEN + FAILED ("-(-LIKE_DURATION'LAST) /= LIKE_DURATION'LAST"); + END IF; + + -- CHECK + AND - MIN: + IF EQUAL (3, 3) THEN + X := MIN; + END IF; + IF +X /= MIN OR +LIKE_DURATION'FIRST /= MIN THEN + FAILED ("+LIKE_DURATION'FIRST /= LIKE_DURATION'FIRST"); + END IF; + IF -(-X) /= MIN OR -(-LIKE_DURATION'FIRST) /= MIN THEN + FAILED("-(-LIKE_DURATION'FIRST) /= LIKE_DURATION'FIRST"); + END IF; + + -- CHECK + AND - SMALL: + IF EQUAL (3, 3) THEN + X := SMALL; + END IF; + IF +X /= SMALL OR +LIKE_DURATION'SMALL /= SMALL THEN + FAILED ("+LIKE_DURATION'SMALL /= LIKE_DURATION'SMALL"); + END IF; + IF -(-X) /= SMALL OR -(-LIKE_DURATION'SMALL) /= SMALL THEN + FAILED("-(-LIKE_DURATION'SMALL) /= LIKE_DURATION'SMALL"); + END IF; + + -- CHECK ARBITRARY MID-RANGE NUMBERS: + IF EQUAL (3, 3) THEN + X := 1000.984_375; + END IF; + IF +X /= 1000.984_375 OR +1000.984_375 /= X THEN + FAILED ("+1000.984_375 /= 1000.984_375"); + END IF; + IF -(-X) /= 1000.984_375 OR -(-1000.984_375) /= X THEN + FAILED ("-(-1000.984_375) /= 1000.984_375"); + END IF; + + -- CHECK "+" AND "-" FOR NON-MODEL NUMBER: + IF +LIKE_DURATION'(NON_MODEL_CONST) NOT IN 0.656_25 .. + 0.671_875 OR + +NON_MODEL_VAR NOT IN 0.656_25 .. 0.671_875 THEN + FAILED ("+LIKE_DURATION'(2.0 / 3) NOT IN 0.656_25 .. " & + "0.671_875"); + END IF; + IF -LIKE_DURATION'(NON_MODEL_CONST) NOT IN -0.671_875 .. + -0.656_25 OR + -NON_MODEL_VAR NOT IN -0.671_875 .. -0.656_25 THEN + FAILED ("-LIKE_DURATION'(2.0 / 3) NOT IN -0.671_875 " & + ".. -0.656_25"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED -- A"); + END A; + + ------------------------------------------------------------------- + +B: DECLARE + TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0; + + NON_MODEL_CONST : CONSTANT := 2.0 / 3; + NON_MODEL_VAR : DECIMAL_M4 := 0.0; + + SMALL, MAX, MIN, ZERO : DECIMAL_M4 := -128.0; + X : DECIMAL_M4 := 0.0; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + NON_MODEL_VAR := NON_MODEL_CONST; + SMALL := DECIMAL_M4'SMALL; + ZERO := 0.0; + END IF; + + -- CHECK + OR - ZERO = ZERO: + IF +ZERO /= 0.0 OR +DECIMAL_M4'(0.0) /= ZERO THEN + FAILED ("+0.0 /= 0.0"); + END IF; + IF -ZERO /= 0.0 OR -DECIMAL_M4'(0.0) /= ZERO THEN + FAILED ("-0.0 /= 0.0"); + END IF; + IF -(-ZERO) /= 0.0 THEN + FAILED ("-(-0.0) /= 0.0"); + END IF; + + -- CHECK + AND - MAX: + IF EQUAL (3, 3) THEN + X := MAX; + END IF; + -- CHECK + AND - SMALL: + IF EQUAL (3, 3) THEN + X := SMALL; + END IF; + IF +X /= SMALL OR +DECIMAL_M4'SMALL /= SMALL THEN + FAILED ("+DECIMAL_M4'SMALL /= DECIMAL_M4'SMALL"); + END IF; + IF -(-X) /= SMALL OR -(-DECIMAL_M4'SMALL) /= SMALL THEN + FAILED ("-(-DECIMAL_M4'SMALL) /= DECIMAL_M4'SMALL"); + END IF; + + -- CHECK ARBITRARY MID-RANGE NUMBERS: + IF EQUAL (3, 3) THEN + X := 256.0; + END IF; + IF +X /= 256.0 OR +256.0 /= X THEN + FAILED ("+256.0 /= 256.0"); + END IF; + IF -(-X) /= 256.0 OR -(-256.0) /= X THEN + FAILED ("-(-256.0) /= 256.0"); + END IF; + + -- CHECK "+" AND "-" FOR NON-MODEL NUMBER: + IF +DECIMAL_M4'(NON_MODEL_CONST) NOT IN 0.0 .. 64.0 OR + +NON_MODEL_VAR NOT IN 0.0 .. 64.0 THEN + FAILED ("+DECIMAL_M4'(2.0 / 3) NOT IN 0.0 .. 64.0"); + END IF; + IF -DECIMAL_M4'(NON_MODEL_CONST) NOT IN -64.0 .. 0.0 OR + -NON_MODEL_VAR NOT IN -64.0 .. 0.0 THEN + FAILED ("-DECIMAL_M4'(2.0 / 3) NOT IN -64.0 .. 0.0"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED -- B"); + END B; + + ------------------------------------------------------------------- + + RESULT; + +END C45431A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c455001.a b/gcc/testsuite/ada/acats/tests/c4/c455001.a new file mode 100644 index 000000000..8685e1b33 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c455001.a @@ -0,0 +1,164 @@ +-- C455001.A + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and +-- F08630-91-C-0015, 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 WHATSOVER, 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 universal fixed multiplying operators can be used without +-- a conversion in contexts where the result type is determined. +-- +-- Note: This is intended to check the changes made to these operators +-- in Ada 95; legacy tests should cover cases from Ada 83. +-- +-- CHANGE HISTORY: +-- 18 MAR 99 RLB Initial version +-- +--! + +with Report; use Report; + +procedure C455001 is + + type F1 is delta 2.0**(-1) range 0.0 .. 8.0; + + type F2 is delta 2.0**(-2) range 0.0 .. 4.0; + + type F3 is delta 2.0**(-3) range 0.0 .. 2.0; + + A : F1; + B : F2; + C : F3; + + type Fixed_Record is record + D : F1; + E : F2; + end record; + + R : Fixed_Record; + + function Ident_Fix (X : F3) return F3 is + begin + if Equal(3,3) then + return X; + else + return 0.0; + end if; + end Ident_Fix; + +begin + Test ("C455001", "Check that universal fixed multiplying operators " & + "can be used without a conversion in contexts where " & + "the result type is determined."); + + A := 1.0; B := 1.0; + C := A * B; -- Assignment context. + + if C /= Ident_Fix(1.0) then + Failed ("Incorrect results for multiplication (1) - result is " & + F3'Image(C)); + end if; + + C := A / B; + + if C /= Ident_Fix(1.0) then + Failed ("Incorrect results for division (1) - result is " & + F3'Image(C)); + end if; + + A := 2.5; + C := A * 0.25; + + if C /= Ident_Fix(0.625) then + Failed ("Incorrect results for multiplication (2) - result is " & + F3'Image(C)); + end if; + + C := A / 4.0; + + if C /= Ident_Fix(0.625) then + Failed ("Incorrect results for division (2) - result is " & + F3'Image(C)); + end if; + + C := Ident_Fix(0.75); + C := C * 0.5; + + if C /= Ident_Fix(0.375) then + Failed ("Incorrect results for multiplication (3) - result is " & + F3'Image(C)); + end if; + + C := Ident_Fix(0.75); + C := C / 0.5; + + if C /= Ident_Fix(1.5) then + Failed ("Incorrect results for division (3) - result is " & + F3'Image(C)); + end if; + + A := 0.5; B := 0.3; -- Function parameter context. + if Ident_Fix(A * B) not in Ident_Fix(0.125) .. Ident_Fix(0.25) then + Failed ("Incorrect results for multiplication (4) - result is " & + F3'Image(A * B)); -- Exact = 0.15 + end if; + + B := 0.8; + if Ident_Fix(A / B) not in Ident_Fix(0.5) .. Ident_Fix(0.75) then + Failed ("Incorrect results for division (4) - result is " & + F3'Image(A / B)); + -- Exact = 0.625..., but B is only restricted to the range + -- 0.75 .. 1.0, so the result can be anywhere in the range + -- 0.5 .. 0.75. + end if; + + C := 0.875; B := 1.5; + R := (D => C * 4.0, E => B / 0.5); -- Aggregate context. + + if R.D /= 3.5 then + Failed ("Incorrect results for multiplication (5) - result is " & + F1'Image(R.D)); + end if; + + if R.E /= 3.0 then + Failed ("Incorrect results for division (5) - result is " & + F2'Image(R.E)); + end if; + + A := 0.5; + C := A * F1'(B * 2.0); -- Qualified expression context. + + if C /= Ident_Fix(1.5) then + Failed ("Incorrect results for multiplication (6) - result is " & + F3'Image(C)); + end if; + + A := 4.0; + C := F1'(B / 0.5) / A; + + if C /= Ident_Fix(0.75) then + Failed ("Incorrect results for division (6) - result is " & + F3'Image(C)); + end if; + + Result; + +end C455001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45502b.dep b/gcc/testsuite/ada/acats/tests/c4/c45502b.dep new file mode 100644 index 000000000..a8bd24ce1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45502b.dep @@ -0,0 +1,291 @@ +-- C45502B.DEP + +-- 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 YIELD CORRECT RESULTS WHEN +-- THE OPERANDS ARE OF PREDEFINED TYPE SHORT_INTEGER. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- SHORT_INTEGER. + +-- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_SHORT" MUST BE REJECTED. + +-- HISTORY: +-- RJW 09/01/86 CREATED ORIGINAL TEST. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + +WITH REPORT; USE REPORT; +PROCEDURE C45502B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (S : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (S))); + END IDENT; + +BEGIN + TEST ( "C45502B", "CHECK THAT MULTIPLICATION AND DIVISION " & + "YIELD CORRECT RESULTS WHEN THE OPERANDS " & + "ARE OF PREDEFINED TYPE SHORT_INTEGER" ); + + DECLARE + I0 : SHORT_INTEGER := 0; + I1 : SHORT_INTEGER := 1; + I2 : SHORT_INTEGER := 2; + I3 : SHORT_INTEGER := 3; + I5 : SHORT_INTEGER := 5; + I10 : SHORT_INTEGER := 10; + I11 : SHORT_INTEGER := 11; + I12 : SHORT_INTEGER := 12; + I13 : SHORT_INTEGER := 13; + I14 : SHORT_INTEGER := 14; + N1 : SHORT_INTEGER := -1; + N2 : SHORT_INTEGER := -2; + N5 : SHORT_INTEGER := -5; + N10 : SHORT_INTEGER := -10; + N11 : SHORT_INTEGER := -11; + N12 : SHORT_INTEGER := -12; + N13 : SHORT_INTEGER := -13; + N14 : SHORT_INTEGER := -14; + N50 : SHORT_INTEGER := -50; + + BEGIN + IF I0 * SHORT_INTEGER'FIRST /= 0 THEN + FAILED ( "INCORRECT RESULT FOR I0 * " & + "SHORT_INTEGER'FIRST" ); + END IF; + + IF I0 * SHORT_INTEGER'LAST /= 0 THEN + FAILED ( "INCORRECT RESULT FOR I0 * " & + "SHORT_INTEGER'LAST" ); + END IF; + + IF N1 * SHORT_INTEGER'LAST + SHORT_INTEGER'LAST /= 0 THEN + FAILED ( "INCORRECT RESULT FOR N1 * " & + "SHORT_INTEGER'LAST" ); + END IF; + + IF I3 * I1 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR I3 * I1" ); + END IF; + + IF IDENT (I3) * IDENT (I1) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I3) * " & + "IDENT (I1)" ); + END IF; + + IF I2 * N1 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I2 * N1" ); + END IF; + + IF "*" (LEFT => I2, RIGHT => N1) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => I2, " & + "RIGHT => N1)" ); + END IF; + + IF IDENT (I2) * IDENT (N1) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I2) * " & + "IDENT (N1)" ); + END IF; + + IF I5 * I2 * N5 /= N50 THEN + FAILED ( "INCORRECT RESULT FOR I5 * I2 * N5" ); + END IF; + + IF IDENT (N1) * IDENT (N5) /= I5 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N1) * " & + "IDENT (N5)" ); + END IF; + + IF "*" (LEFT => IDENT (N1), RIGHT => IDENT (N5)) /= + I5 THEN + FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => " & + "IDENT (N1), RIGHT => IDENT (N5))" ); + END IF; + + IF IDENT (N1) * IDENT (I2) * IDENT (N5) /= I10 + THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N1) * " & + "IDENT (I2) * IDENT (N5)" ); + END IF; + + IF (-IDENT (I0)) * IDENT (I10) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR (-IDENT (I0)) * " & + "IDENT (I10)" ); + END IF; + + IF I0 * I10 /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR I0 * I10" ); + END IF; + + IF "*" (LEFT => I0, RIGHT => I10) /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => I0, " & + "RIGHT => I10)" ); + END IF; + + IF IDENT (I10) / IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I10) " & + "/ IDENT (I5)" ); + END IF; + + IF I11 / I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I11 / I5" ); + END IF; + + IF IDENT (I12) / IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I12) " & + "/ IDENT (I5)" ); + END IF; + + IF "/" (LEFT => IDENT (I12), RIGHT => IDENT (I5)) /= + I2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " & + "IDENT (I12), RIGHT => IDENT (I5))" ); + END IF; + + IF I13 / I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I13 / I5" ); + END IF; + + IF IDENT (I14) / IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I14) " & + "/ IDENT (I5)" ); + END IF; + + IF I10 / N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I10 / N5" ); + END IF; + + IF "/" (LEFT => I10, RIGHT => N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => I10, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT (I11) / IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I11) " & + "/ IDENT (N5)" ); + END IF; + + IF I12 / N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I12 / N5" ); + END IF; + + IF IDENT (I13) / IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I13) " & + "/ IDENT (N5)" ); + END IF; + + IF I14 / N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I14 / N5" ); + END IF; + + IF IDENT (N10) / IDENT (I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N10) " & + "/ IDENT (I5)" ); + END IF; + + IF "/" (LEFT => IDENT (N10), RIGHT => IDENT (I5)) /= + N2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " & + "IDENT (N10), RIGHT => IDENT (I5))" ); + END IF; + + IF N11 / I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N11 / I5" ); + END IF; + + IF IDENT (N12) / IDENT (I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N12) " & + "/ IDENT (I5)" ); + END IF; + + IF N13 / I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N13 / I5" ); + END IF; + + IF "/" (LEFT => N13, RIGHT => I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => N13, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (N14) / IDENT (I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N14) " & + "/ IDENT (I5)" ); + END IF; + + IF N10 / N5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR N10 / N5" ); + END IF; + + IF IDENT (N11) / IDENT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N11) " & + "/ IDENT (N5)" ); + END IF; + + IF "/" (LEFT => IDENT (N11), RIGHT => IDENT (N5)) /= + I2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " & + "IDENT (N11), RIGHT => IDENT (N5))" ); + END IF; + + IF N12 / N5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR N12 / N5" ); + END IF; + + + IF IDENT (N13) / IDENT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N13) " & + "/ IDENT (N5)" ); + END IF; + + IF N14 / N5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR N14 / N5" ); + END IF; + + IF "/" (LEFT => N14, RIGHT => N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => N14, " & + "RIGHT => N5)" ); + END IF; + + IF I0 / I5 /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR I0 / I5" ); + END IF; + + IF "/" (LEFT => I0, RIGHT => I5) /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => I0, " & + "RIGHT => I5)" ); + END IF; + + IF (-IDENT (I0)) / IDENT (I5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR (-IDENT (I0)) / " & + "IDENT (I5)" ); + END IF; + + END; + + RESULT; +END C45502B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45502c.dep b/gcc/testsuite/ada/acats/tests/c4/c45502c.dep new file mode 100644 index 000000000..96d0212d8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45502c.dep @@ -0,0 +1,295 @@ +-- C45502C.DEP + +-- 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 YIELD CORRECT RESULTS WHEN +-- THE OPERANDS ARE OF PREDEFINED TYPE LONG_INTEGER. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- LONG_INTEGER. + +-- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_LONG" MUST BE REJECTED. + +-- HISTORY: +-- RJW 09/01/86 +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + +WITH REPORT; USE REPORT; +PROCEDURE C45502C IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (S : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN S; + ELSE + RETURN 0; + END IF; + END IDENT; + +BEGIN + TEST ( "C45502C", "CHECK THAT MULTIPLICATION AND DIVISION " & + "YIELD CORRECT RESULTS WHEN THE OPERANDS " & + "ARE OF PREDEFINED TYPE LONG_INTEGER" ); + + DECLARE + I0 : LONG_INTEGER := 0; + I1 : LONG_INTEGER := 1; + I2 : LONG_INTEGER := 2; + I3 : LONG_INTEGER := 3; + I5 : LONG_INTEGER := 5; + I10 : LONG_INTEGER := 10; + I11 : LONG_INTEGER := 11; + I12 : LONG_INTEGER := 12; + I13 : LONG_INTEGER := 13; + I14 : LONG_INTEGER := 14; + N1 : LONG_INTEGER := -1; + N2 : LONG_INTEGER := -2; + N5 : LONG_INTEGER := -5; + N10 : LONG_INTEGER := -10; + N11 : LONG_INTEGER := -11; + N12 : LONG_INTEGER := -12; + N13 : LONG_INTEGER := -13; + N14 : LONG_INTEGER := -14; + N50 : LONG_INTEGER := -50; + + BEGIN + IF I0 * LONG_INTEGER'FIRST /= 0 THEN + FAILED ( "INCORRECT RESULT FOR I0 * " & + "LONG_INTEGER'FIRST" ); + END IF; + + IF I0 * LONG_INTEGER'LAST /= 0 THEN + FAILED ( "INCORRECT RESULT FOR I0 * " & + "LONG_INTEGER'LAST" ); + END IF; + + IF N1 * LONG_INTEGER'LAST + LONG_INTEGER'LAST /= 0 THEN + FAILED ( "INCORRECT RESULT FOR N1 * " & + "LONG_INTEGER'LAST" ); + END IF; + + IF I3 * I1 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR I3 * I1" ); + END IF; + + IF IDENT (I3) * IDENT (I1) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I3) * " & + "IDENT (I1)" ); + END IF; + + IF I2 * N1 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I2 * N1" ); + END IF; + + IF "*" (LEFT => I2, RIGHT => N1) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => I2, " & + "RIGHT => N1)" ); + END IF; + + IF IDENT (I2) * IDENT (N1) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I2) * " & + "IDENT (N1)" ); + END IF; + + IF I5 * I2 * N5 /= N50 THEN + FAILED ( "INCORRECT RESULT FOR I5 * I2 * N5" ); + END IF; + + IF IDENT (N1) * IDENT (N5) /= I5 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N1) * " & + "IDENT (N5)" ); + END IF; + + IF "*" (LEFT => IDENT (N1), RIGHT => IDENT (N5)) /= + I5 THEN + FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => " & + "IDENT (N1), RIGHT => IDENT (N5))" ); + END IF; + + IF IDENT (N1) * IDENT (I2) * IDENT (N5) /= I10 + THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N1) * " & + "IDENT (I2) * IDENT (N5)" ); + END IF; + + IF (-IDENT (I0)) * IDENT (I10) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR (-IDENT (I0)) * " & + "IDENT (I10)" ); + END IF; + + IF I0 * I10 /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR I0 * I10" ); + END IF; + + IF "*" (LEFT => I0, RIGHT => I10) /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => I0, " & + "RIGHT => I10)" ); + END IF; + + IF IDENT (I10) / IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I10) " & + "/ IDENT (I5)" ); + END IF; + + IF I11 / I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I11 / I5" ); + END IF; + + IF IDENT (I12) / IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I12) " & + "/ IDENT (I5)" ); + END IF; + + IF "/" (LEFT => IDENT (I12), RIGHT => IDENT (I5)) /= + I2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " & + "IDENT (I12), RIGHT => IDENT (I5))" ); + END IF; + + IF I13 / I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I13 / I5" ); + END IF; + + IF IDENT (I14) / IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I14) " & + "/ IDENT (I5)" ); + END IF; + + IF I10 / N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I10 / N5" ); + END IF; + + IF "/" (LEFT => I10, RIGHT => N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => I10, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT (I11) / IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I11) " & + "/ IDENT (N5)" ); + END IF; + + IF I12 / N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I12 / N5" ); + END IF; + + IF IDENT (I13) / IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I13) " & + "/ IDENT (N5)" ); + END IF; + + IF I14 / N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I14 / N5" ); + END IF; + + IF IDENT (N10) / IDENT (I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N10) " & + "/ IDENT (I5)" ); + END IF; + + IF "/" (LEFT => IDENT (N10), RIGHT => IDENT (I5)) /= + N2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " & + "IDENT (N10), RIGHT => IDENT (I5))" ); + END IF; + + IF N11 / I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N11 / I5" ); + END IF; + + IF IDENT (N12) / IDENT (I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N12) " & + "/ IDENT (I5)" ); + END IF; + + IF N13 / I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N13 / I5" ); + END IF; + + IF "/" (LEFT => N13, RIGHT => I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => N13, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (N14) / IDENT (I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N14) " & + "/ IDENT (I5)" ); + END IF; + + IF N10 / N5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR N10 / N5" ); + END IF; + + IF IDENT (N11) / IDENT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N11) " & + "/ IDENT (N5)" ); + END IF; + + IF "/" (LEFT => IDENT (N11), RIGHT => IDENT (N5)) /= + I2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " & + "IDENT (N11), RIGHT => IDENT (N5))" ); + END IF; + + IF N12 / N5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR N12 / N5" ); + END IF; + + + IF IDENT (N13) / IDENT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N13) " & + "/ IDENT (N5)" ); + END IF; + + IF N14 / N5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR N14 / N5" ); + END IF; + + IF "/" (LEFT => N14, RIGHT => N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => N14, " & + "RIGHT => N5)" ); + END IF; + + IF I0 / I5 /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR I0 / I5" ); + END IF; + + IF "/" (LEFT => I0, RIGHT => I5) /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => I0, " & + "RIGHT => I5)" ); + END IF; + + IF (-IDENT (I0)) / IDENT (I5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR (-IDENT (I0)) / " & + "IDENT (I5)" ); + END IF; + + END; + + RESULT; +END C45502C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45503a.ada b/gcc/testsuite/ada/acats/tests/c4/c45503a.ada new file mode 100644 index 000000000..0461b0151 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45503a.ada @@ -0,0 +1,310 @@ +-- C45503A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT 'REM' AND 'MOD' YIELD CORRECT RESULTS WHEN THE OPERANDS +-- ARE OF PREDEFINED TYPE INTEGER. + +-- R.WILLIAMS 9/1/86 + +WITH REPORT; USE REPORT; +PROCEDURE C45503A IS + +BEGIN + TEST ( "C45503A", "CHECK THAT 'REM' AND 'MOD' YIELD CORRECT " & + "RESULTS WHEN THE OPERANDS ARE OF PREDEFINED " & + "TYPE INTEGER" ); + + DECLARE + I0 : INTEGER := 0; + I1 : INTEGER := 1; + I2 : INTEGER := 2; + I3 : INTEGER := 3; + I4 : INTEGER := 4; + I5 : INTEGER := 5; + I10 : INTEGER := 10; + I11 : INTEGER := 11; + I12 : INTEGER := 12; + I13 : INTEGER := 13; + I14 : INTEGER := 14; + N1 : INTEGER := -1; + N2 : INTEGER := -2; + N3 : INTEGER := -3; + N4 : INTEGER := -4; + N5 : INTEGER := -5; + N10 : INTEGER := -10; + N11 : INTEGER := -11; + N12 : INTEGER := -12; + N13 : INTEGER := -13; + N14 : INTEGER := -14; + + BEGIN + IF I10 REM I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR I10 REM I5" ); + END IF; + + IF IDENT_INT (I11) REM IDENT_INT (I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I11) REM " & + "IDENT_INT (I5)" ); + END IF; + + IF I12 REM I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I12 REM I5" ); + END IF; + + IF "REM" (LEFT => I12, RIGHT => I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I12, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT_INT (I13) REM IDENT_INT (I5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I13) REM " & + "IDENT_INT (I5)" ); + END IF; + + IF I14 REM I5 /= I4 THEN + FAILED ( "INCORRECT RESULT FOR I14 REM I5" ); + END IF; + + IF IDENT_INT (I10) REM IDENT_INT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I10) REM " & + "IDENT_INT (N5)" ); + END IF; + + IF "REM" (LEFT => IDENT_INT (I10), RIGHT => IDENT_INT (N5)) + /= I0 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT_INT (I10), RIGHT => IDENT_INT (N5))" ); + END IF; + + IF I11 REM N5 /= I1 THEN + FAILED ( "INCORRECT RESULT FOR I11 REM N5" ); + END IF; + + IF IDENT_INT (I12) REM IDENT_INT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I12) REM " & + "IDENT_INT (N5)" ); + END IF; + + IF I13 REM N5 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR I13 REM N5" ); + END IF; + + IF "REM" (LEFT => I13, RIGHT => N5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I13, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT_INT (I14) REM IDENT_INT (N5) /= I4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I14) REM " & + "IDENT_INT (N5)" ); + END IF; + + IF N10 REM I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR N10 REM I5" ); + END IF; + + IF IDENT_INT (N11) REM IDENT_INT (I5) /= N1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N11) REM " & + "IDENT_INT (I5)" ); + END IF; + + IF "REM" (LEFT => IDENT_INT (N11), RIGHT => IDENT_INT (I5)) + /= N1 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT_INT (N11), RIGHT => IDENT_INT (I5))" ); + END IF; + + IF N12 REM I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N12 REM I5" ); + END IF; + + IF IDENT_INT (N13) REM IDENT_INT (I5) /= N3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N13) REM " & + "IDENT_INT (I5)" ); + END IF; + + IF N14 REM I5 /= N4 THEN + FAILED ( "INCORRECT RESULT FOR N14 REM I5" ); + END IF; + + IF "REM" (LEFT => N14, RIGHT => I5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => N14, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT_INT (N10) REM IDENT_INT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N10) REM " & + "IDENT_INT (N5)" ); + END IF; + + IF N11 REM N5 /= N1 THEN + FAILED ( "INCORRECT RESULT FOR N11 REM N5" ); + END IF; + + IF IDENT_INT (N12) REM IDENT_INT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N12) REM " & + "IDENT_INT (N5)" ); + END IF; + + IF "REM" (LEFT => IDENT_INT (N12), RIGHT => IDENT_INT (N5)) + /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT_INT (N12), RIGHT => IDENT_INT (N5))" ); + END IF; + + IF N13 REM N5 /= N3 THEN + FAILED ( "INCORRECT RESULT FOR N13 REM N5" ); + END IF; + + IF IDENT_INT (N14) REM IDENT_INT (N5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N14) REM " & + "IDENT_INT (N5)" ); + END IF; + + IF I10 MOD I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR I10 MOD I5" ); + END IF; + + IF IDENT_INT (I11) MOD IDENT_INT (I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I11) MOD " & + "IDENT_INT (I5)" ); + END IF; + + IF I12 MOD I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I12 MOD I5" ); + END IF; + + IF "MOD" (LEFT => I12, RIGHT => I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I12, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT_INT (I13) MOD IDENT_INT (I5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I13) MOD " & + "IDENT_INT (I5)" ); + END IF; + + IF I14 MOD I5 /= I4 THEN + FAILED ( "INCORRECT RESULT FOR I14 MOD I5" ); + END IF; + + IF IDENT_INT (I10) MOD IDENT_INT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I10) MOD " & + "IDENT_INT (N5)" ); + END IF; + + IF "MOD" (LEFT => IDENT_INT (I10), RIGHT => IDENT_INT (N5)) + /= I0 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT_INT (I10), RIGHT => IDENT_INT (N5))" ); + END IF; + + IF I11 MOD N5 /= N4 THEN + FAILED ( "INCORRECT RESULT FOR I11 MOD N5" ); + END IF; + + IF IDENT_INT (I12) MOD IDENT_INT (N5) /= N3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I12) MOD " & + "IDENT_INT (N5)" ); + END IF; + + IF I13 MOD N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I13 MOD N5" ); + END IF; + + IF "MOD" (LEFT => I13, RIGHT => N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I13, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT_INT (I14) MOD IDENT_INT (N5) /= N1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I14) MOD " & + "IDENT_INT (N5)" ); + END IF; + + IF N10 MOD I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR N10 MOD I5" ); + END IF; + + IF IDENT_INT (N11) MOD IDENT_INT (I5) /= I4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N11) MOD " & + "IDENT_INT (I5)" ); + END IF; + + IF "MOD" (LEFT => IDENT_INT (N11), RIGHT => IDENT_INT (I5)) + /= I4 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT_INT (N11), RIGHT => IDENT_INT (I5))" ); + END IF; + + IF N12 MOD I5 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR N12 MOD I5" ); + END IF; + + IF IDENT_INT (N13) MOD IDENT_INT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N13) MOD " & + "IDENT_INT (I5)" ); + END IF; + + IF N14 MOD I5 /= I1 THEN + FAILED ( "INCORRECT RESULT FOR N14 MOD I5" ); + END IF; + + IF "MOD" (LEFT => N14, RIGHT => I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I14, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT_INT (N10) MOD IDENT_INT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N10) MOD " & + "IDENT_INT (N5)" ); + END IF; + + IF N11 MOD N5 /= N1 THEN + FAILED ( "INCORRECT RESULT FOR N11 MOD N5" ); + END IF; + + IF IDENT_INT (N12) MOD IDENT_INT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N12) MOD " & + "IDENT_INT (N5)" ); + END IF; + + IF "MOD" (LEFT => IDENT_INT (N12), RIGHT => IDENT_INT (N5)) + /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT_INT (N12), RIGHT => IDENT_INT (N5))" ); + END IF; + + IF N13 MOD N5 /= N3 THEN + FAILED ( "INCORRECT RESULT FOR N13 MOD N5" ); + END IF; + + IF IDENT_INT (N14) MOD IDENT_INT (N5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N14) MOD " & + "IDENT_INT (N5)" ); + END IF; + END; + + RESULT; +END C45503A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45503b.dep b/gcc/testsuite/ada/acats/tests/c4/c45503b.dep new file mode 100644 index 000000000..570c52934 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45503b.dep @@ -0,0 +1,327 @@ +-- C45503B.DEP + +-- 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 'REM' AND 'MOD' YIELD CORRECT RESULTS WHEN THE +-- OPERANDS ARE OF PREDEFINED TYPE SHORT_INTEGER. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- SHORT_INTEGER. + +-- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_SHORT" MUST BE REJECTED. + +-- HISTORY: +-- RJW 09/01/86 CREATED ORIGINAL TEST. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + +WITH REPORT; USE REPORT; +PROCEDURE C45503B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (S : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (S))); + END IDENT; + +BEGIN + TEST ( "C45503B", "CHECK THAT 'REM' AND 'MOD' YIELD CORRECT " & + "RESULTS WHEN THE OPERANDS ARE OF PREDEFINED " & + "TYPE SHORT_INTEGER" ); + + DECLARE + I0 : SHORT_INTEGER := 0; + I1 : SHORT_INTEGER := 1; + I2 : SHORT_INTEGER := 2; + I3 : SHORT_INTEGER := 3; + I4 : SHORT_INTEGER := 4; + I5 : SHORT_INTEGER := 5; + I10 : SHORT_INTEGER := 10; + I11 : SHORT_INTEGER := 11; + I12 : SHORT_INTEGER := 12; + I13 : SHORT_INTEGER := 13; + I14 : SHORT_INTEGER := 14; + N1 : SHORT_INTEGER := -1; + N2 : SHORT_INTEGER := -2; + N3 : SHORT_INTEGER := -3; + N4 : SHORT_INTEGER := -4; + N5 : SHORT_INTEGER := -5; + N10 : SHORT_INTEGER := -10; + N11 : SHORT_INTEGER := -11; + N12 : SHORT_INTEGER := -12; + N13 : SHORT_INTEGER := -13; + N14 : SHORT_INTEGER := -14; + + BEGIN + IF I10 REM I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR I10 REM I5" ); + END IF; + + IF IDENT (I11) REM IDENT (I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I11) REM " & + "IDENT (I5)" ); + END IF; + + IF I12 REM I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I12 REM I5" ); + END IF; + + IF "REM" (LEFT => I12, RIGHT => I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I12, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (I13) REM IDENT (I5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I13) REM " & + "IDENT (I5)" ); + END IF; + + IF I14 REM I5 /= I4 THEN + FAILED ( "INCORRECT RESULT FOR I14 REM I5" ); + END IF; + + IF IDENT (I10) REM IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I10) REM " & + "IDENT (N5)" ); + END IF; + + IF "REM" (LEFT => IDENT (I10), RIGHT => IDENT (N5)) + /= I0 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT (I10), RIGHT => IDENT (N5))" ); + END IF; + + IF I11 REM N5 /= I1 THEN + FAILED ( "INCORRECT RESULT FOR I11 REM N5" ); + END IF; + + IF IDENT (I12) REM IDENT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I12) REM " & + "IDENT (N5)" ); + END IF; + + IF I13 REM N5 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR I13 REM N5" ); + END IF; + + IF "REM" (LEFT => I13, RIGHT => N5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I13, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT (I14) REM IDENT (N5) /= I4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I14) REM " & + "IDENT (N5)" ); + END IF; + + IF N10 REM I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR N10 REM I5" ); + END IF; + + IF IDENT (N11) REM IDENT (I5) /= N1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N11) REM " & + "IDENT (I5)" ); + END IF; + + IF "REM" (LEFT => IDENT (N11), RIGHT => IDENT (I5)) + /= N1 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT (N11), RIGHT => IDENT (I5))" ); + END IF; + + IF N12 REM I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N12 REM I5" ); + END IF; + + IF IDENT (N13) REM IDENT (I5) /= N3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N13) REM " & + "IDENT (I5)" ); + END IF; + + IF N14 REM I5 /= N4 THEN + FAILED ( "INCORRECT RESULT FOR N14 REM I5" ); + END IF; + + IF "REM" (LEFT => N14, RIGHT => I5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => N14, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (N10) REM IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N10) REM " & + "IDENT (N5)" ); + END IF; + + IF N11 REM N5 /= N1 THEN + FAILED ( "INCORRECT RESULT FOR N11 REM N5" ); + END IF; + + IF IDENT (N12) REM IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N12) REM " & + "IDENT (N5)" ); + END IF; + + IF "REM" (LEFT => IDENT (N12), RIGHT => IDENT (N5)) + /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT (N12), RIGHT => IDENT (N5))" ); + END IF; + + IF N13 REM N5 /= N3 THEN + FAILED ( "INCORRECT RESULT FOR N13 REM N5" ); + END IF; + + IF IDENT (N14) REM IDENT (N5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N14) REM " & + "IDENT (N5)" ); + END IF; + + IF I10 MOD I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR I10 MOD I5" ); + END IF; + + IF IDENT (I11) MOD IDENT (I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I11) MOD " & + "IDENT (I5)" ); + END IF; + + IF I12 MOD I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I12 MOD I5" ); + END IF; + + IF "MOD" (LEFT => I12, RIGHT => I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I12, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (I13) MOD IDENT (I5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I13) MOD " & + "IDENT (I5)" ); + END IF; + + IF I14 MOD I5 /= I4 THEN + FAILED ( "INCORRECT RESULT FOR I14 MOD I5" ); + END IF; + + IF IDENT (I10) MOD IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I10) MOD " & + "IDENT (N5)" ); + END IF; + + IF "MOD" (LEFT => IDENT (I10), RIGHT => IDENT (N5)) + /= I0 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT (I10), RIGHT => IDENT (N5))" ); + END IF; + + IF I11 MOD N5 /= N4 THEN + FAILED ( "INCORRECT RESULT FOR I11 MOD N5" ); + END IF; + + IF IDENT (I12) MOD IDENT (N5) /= N3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I12) MOD " & + "IDENT (N5)" ); + END IF; + + IF I13 MOD N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I13 MOD N5" ); + END IF; + + IF "MOD" (LEFT => I13, RIGHT => N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I13, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT (I14) MOD IDENT (N5) /= N1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I14) MOD " & + "IDENT (N5)" ); + END IF; + + IF N10 MOD I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR N10 MOD I5" ); + END IF; + + IF IDENT (N11) MOD IDENT (I5) /= I4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N11) MOD " & + "IDENT (I5)" ); + END IF; + + IF "MOD" (LEFT => IDENT (N11), RIGHT => IDENT (I5)) + /= I4 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT (N11), RIGHT => IDENT (I5))" ); + END IF; + + IF N12 MOD I5 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR N12 MOD I5" ); + END IF; + + IF IDENT (N13) MOD IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N13) MOD " & + "IDENT (I5)" ); + END IF; + + IF N14 MOD I5 /= I1 THEN + FAILED ( "INCORRECT RESULT FOR N14 MOD I5" ); + END IF; + + IF "MOD" (LEFT => N14, RIGHT => I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I14, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (N10) MOD IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N10) MOD " & + "IDENT (N5)" ); + END IF; + + IF N11 MOD N5 /= N1 THEN + FAILED ( "INCORRECT RESULT FOR N11 MOD N5" ); + END IF; + + IF IDENT (N12) MOD IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N12) MOD " & + "IDENT (N5)" ); + END IF; + + IF "MOD" (LEFT => IDENT (N12), RIGHT => IDENT (N5)) + /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT (N12), RIGHT => IDENT (N5))" ); + END IF; + + IF N13 MOD N5 /= N3 THEN + FAILED ( "INCORRECT RESULT FOR N13 MOD N5" ); + END IF; + + IF IDENT (N14) MOD IDENT (N5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N14) MOD " & + "IDENT (N5)" ); + END IF; + END; + + RESULT; +END C45503B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45503c.dep b/gcc/testsuite/ada/acats/tests/c4/c45503c.dep new file mode 100644 index 000000000..9a66c3529 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45503c.dep @@ -0,0 +1,331 @@ +-- C45503C.DEP + +-- 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 'REM' AND 'MOD' YIELD CORRECT RESULTS WHEN THE +-- OPERANDS ARE OF PREDEFINED TYPE LONG_INTEGER. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- LONG_INTEGER. + +-- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_LONG" MUST BE REJECTED. + +-- HISTORY: +-- RJW 09/01/86 CREATED ORIGINAL TEST. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + +WITH REPORT; USE REPORT; +PROCEDURE C45503C IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (L : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN L; + ELSE + RETURN 0; + END IF; + END IDENT; + +BEGIN + TEST ( "C45503C", "CHECK THAT 'REM' AND 'MOD' YIELD CORRECT " & + "RESULTS WHEN THE OPERANDS ARE OF PREDEFINED " & + "TYPE LONG_INTEGER" ); + + DECLARE + I0 : LONG_INTEGER := 0; + I1 : LONG_INTEGER := 1; + I2 : LONG_INTEGER := 2; + I3 : LONG_INTEGER := 3; + I4 : LONG_INTEGER := 4; + I5 : LONG_INTEGER := 5; + I10 : LONG_INTEGER := 10; + I11 : LONG_INTEGER := 11; + I12 : LONG_INTEGER := 12; + I13 : LONG_INTEGER := 13; + I14 : LONG_INTEGER := 14; + N1 : LONG_INTEGER := -1; + N2 : LONG_INTEGER := -2; + N3 : LONG_INTEGER := -3; + N4 : LONG_INTEGER := -4; + N5 : LONG_INTEGER := -5; + N10 : LONG_INTEGER := -10; + N11 : LONG_INTEGER := -11; + N12 : LONG_INTEGER := -12; + N13 : LONG_INTEGER := -13; + N14 : LONG_INTEGER := -14; + + BEGIN + IF I10 REM I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR I10 REM I5" ); + END IF; + + IF IDENT (I11) REM IDENT (I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I11) REM " & + "IDENT (I5)" ); + END IF; + + IF I12 REM I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I12 REM I5" ); + END IF; + + IF "REM" (LEFT => I12, RIGHT => I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I12, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (I13) REM IDENT (I5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I13) REM " & + "IDENT (I5)" ); + END IF; + + IF I14 REM I5 /= I4 THEN + FAILED ( "INCORRECT RESULT FOR I14 REM I5" ); + END IF; + + IF IDENT (I10) REM IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I10) REM " & + "IDENT (N5)" ); + END IF; + + IF "REM" (LEFT => IDENT (I10), RIGHT => IDENT (N5)) + /= I0 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT (I10), RIGHT => IDENT (N5))" ); + END IF; + + IF I11 REM N5 /= I1 THEN + FAILED ( "INCORRECT RESULT FOR I11 REM N5" ); + END IF; + + IF IDENT (I12) REM IDENT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I12) REM " & + "IDENT (N5)" ); + END IF; + + IF I13 REM N5 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR I13 REM N5" ); + END IF; + + IF "REM" (LEFT => I13, RIGHT => N5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I13, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT (I14) REM IDENT (N5) /= I4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I14) REM " & + "IDENT (N5)" ); + END IF; + + IF N10 REM I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR N10 REM I5" ); + END IF; + + IF IDENT (N11) REM IDENT (I5) /= N1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N11) REM " & + "IDENT (I5)" ); + END IF; + + IF "REM" (LEFT => IDENT (N11), RIGHT => IDENT (I5)) + /= N1 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT (N11), RIGHT => IDENT (I5))" ); + END IF; + + IF N12 REM I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N12 REM I5" ); + END IF; + + IF IDENT (N13) REM IDENT (I5) /= N3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N13) REM " & + "IDENT (I5)" ); + END IF; + + IF N14 REM I5 /= N4 THEN + FAILED ( "INCORRECT RESULT FOR N14 REM I5" ); + END IF; + + IF "REM" (LEFT => N14, RIGHT => I5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => N14, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (N10) REM IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N10) REM " & + "IDENT (N5)" ); + END IF; + + IF N11 REM N5 /= N1 THEN + FAILED ( "INCORRECT RESULT FOR N11 REM N5" ); + END IF; + + IF IDENT (N12) REM IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N12) REM " & + "IDENT (N5)" ); + END IF; + + IF "REM" (LEFT => IDENT (N12), RIGHT => IDENT (N5)) + /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT (N12), RIGHT => IDENT (N5))" ); + END IF; + + IF N13 REM N5 /= N3 THEN + FAILED ( "INCORRECT RESULT FOR N13 REM N5" ); + END IF; + + IF IDENT (N14) REM IDENT (N5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N14) REM " & + "IDENT (N5)" ); + END IF; + + IF I10 MOD I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR I10 MOD I5" ); + END IF; + + IF IDENT (I11) MOD IDENT (I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I11) MOD " & + "IDENT (I5)" ); + END IF; + + IF I12 MOD I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I12 MOD I5" ); + END IF; + + IF "MOD" (LEFT => I12, RIGHT => I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I12, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (I13) MOD IDENT (I5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I13) MOD " & + "IDENT (I5)" ); + END IF; + + IF I14 MOD I5 /= I4 THEN + FAILED ( "INCORRECT RESULT FOR I14 MOD I5" ); + END IF; + + IF IDENT (I10) MOD IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I10) MOD " & + "IDENT (N5)" ); + END IF; + + IF "MOD" (LEFT => IDENT (I10), RIGHT => IDENT (N5)) + /= I0 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT (I10), RIGHT => IDENT (N5))" ); + END IF; + + IF I11 MOD N5 /= N4 THEN + FAILED ( "INCORRECT RESULT FOR I11 MOD N5" ); + END IF; + + IF IDENT (I12) MOD IDENT (N5) /= N3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I12) MOD " & + "IDENT (N5)" ); + END IF; + + IF I13 MOD N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I13 MOD N5" ); + END IF; + + IF "MOD" (LEFT => I13, RIGHT => N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I13, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT (I14) MOD IDENT (N5) /= N1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I14) MOD " & + "IDENT (N5)" ); + END IF; + + IF N10 MOD I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR N10 MOD I5" ); + END IF; + + IF IDENT (N11) MOD IDENT (I5) /= I4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N11) MOD " & + "IDENT (I5)" ); + END IF; + + IF "MOD" (LEFT => IDENT (N11), RIGHT => IDENT (I5)) + /= I4 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT (N11), RIGHT => IDENT (I5))" ); + END IF; + + IF N12 MOD I5 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR N12 MOD I5" ); + END IF; + + IF IDENT (N13) MOD IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N13) MOD " & + "IDENT (I5)" ); + END IF; + + IF N14 MOD I5 /= I1 THEN + FAILED ( "INCORRECT RESULT FOR N14 MOD I5" ); + END IF; + + IF "MOD" (LEFT => N14, RIGHT => I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I14, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (N10) MOD IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N10) MOD " & + "IDENT (N5)" ); + END IF; + + IF N11 MOD N5 /= N1 THEN + FAILED ( "INCORRECT RESULT FOR N11 MOD N5" ); + END IF; + + IF IDENT (N12) MOD IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N12) MOD " & + "IDENT (N5)" ); + END IF; + + IF "MOD" (LEFT => IDENT (N12), RIGHT => IDENT (N5)) + /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT (N12), RIGHT => IDENT (N5))" ); + END IF; + + IF N13 MOD N5 /= N3 THEN + FAILED ( "INCORRECT RESULT FOR N13 MOD N5" ); + END IF; + + IF IDENT (N14) MOD IDENT (N5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N14) MOD " & + "IDENT (N5)" ); + END IF; + END; + + RESULT; +END C45503C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45504a.ada b/gcc/testsuite/ada/acats/tests/c4/c45504a.ada new file mode 100644 index 000000000..7cc4af4bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45504a.ada @@ -0,0 +1,92 @@ +-- C45504A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN A +-- PRODUCT LIES OUTSIDE THE RANGE OF THE BASE TYPE, IF THE +-- OPERANDS ARE OF PREDEFINED TYPE INTEGER. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- HISTORY: +-- RJW 09/01/86 CREATED ORIGINAL TEST. +-- JET 12/30/87 UPDATED HEADER FORMAT AND ADDED CODE TO +-- PREVENT OPTIMIZATION. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45504A IS + + F : INTEGER := IDENT_INT (INTEGER'FIRST); + L : INTEGER := IDENT_INT (INTEGER'LAST); + +BEGIN + TEST ( "C45504A", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED WHEN A PRODUCT LIES OUTSIDE THE " & + "RANGE OF THE BASE TYPE, IF THE OPERANDS ARE " & + "OF PREDEFINED TYPE INTEGER" ); + + BEGIN + IF EQUAL (F*L,-100) THEN + FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * L'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'F * L'" ); + END; + + BEGIN + IF EQUAL (F*F,100) THEN + FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * F'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'F * F'" ); + END; + + BEGIN + IF EQUAL (L*L,100) THEN + FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'L * L'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'L * L'" ); + END; + + RESULT; +END C45504A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45504b.dep b/gcc/testsuite/ada/acats/tests/c4/c45504b.dep new file mode 100644 index 000000000..230750540 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45504b.dep @@ -0,0 +1,117 @@ +-- C45504B.DEP + +-- 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 CONSTRAINT_ERROR IS RAISED WHEN +-- A PRODUCT LIES OUTSIDE THE RANGE OF THE BASE TYPE, IF +-- THE OPERANDS ARE OF PREDEFINED TYPE SHORT_INTEGER. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT +-- THE PREDEFINED TYPE "SHORT_INTEGER". + +-- IF SUCH A TYPE IS NOT SUPPORTED, THEN THE DECLARATION OF +-- THE VARIABLE "F" MUST BE REJECTED. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- HISTORY: +-- RJW 09/01/86 CREATED ORIGINAL TEST. +-- JET 12/30/87 UPDATED HEADER FORMAT AND ADDED CODE TO +-- DEFEAT OPTIMIZATION. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45504B IS + + F : SHORT_INTEGER; -- N/A => ERROR. + L : SHORT_INTEGER; + + FUNCTION IDENT_SHORT(A : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + IF EQUAL (3,3) THEN + RETURN A; + ELSE + RETURN 0; + END IF; + END IDENT_SHORT; + + FUNCTION SHORT_OK(X : SHORT_INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN X = IDENT_SHORT(X); + END SHORT_OK; + +BEGIN + TEST ( "C45504B", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED WHEN A PRODUCT LIES OUTSIDE THE " & + "RANGE OF THE BASE TYPE, IF THE OPERANDS ARE " & + "OF PREDEFINED TYPE SHORT_INTEGER" ); + + F := IDENT_SHORT(SHORT_INTEGER'FIRST); + L := IDENT_SHORT(SHORT_INTEGER'LAST); + + BEGIN + IF SHORT_OK (F*L) THEN + FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * L'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'F * L'" ); + END; + + BEGIN + IF SHORT_OK (F * F) THEN + FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * F'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'F * F'" ); + END; + + BEGIN + IF SHORT_OK (L * L) THEN + FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'L * L'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'L * L'" ); + END; + + RESULT; + +END C45504B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45504c.dep b/gcc/testsuite/ada/acats/tests/c4/c45504c.dep new file mode 100644 index 000000000..d39ee6378 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45504c.dep @@ -0,0 +1,119 @@ +-- C45504C.DEP + +-- 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 CONSTRAINT_ERROR IS RAISED WHEN A +-- PRODUCT LIES OUTSIDE THE RANGE OF THE BASE TYPE, IF THE +-- OPERANDS ARE OF PREDEFINED TYPE LONG_INTEGER. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT +-- THE PREDEFINED TYPE "LONG_INTEGER". + +-- IF SUCH A TYPE IS NOT SUPPORTED THEN THE DECLARATION OF THE +-- VARIABLE "F" MUST BE REJECTED. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- HISTORY: +-- RJW 09/01/86 CREATED ORIGINAL TEST. +-- JET 12/30/87 UPDATED HEADER FORMAT AND DEFEATED OPTIMIZATION. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45504C IS + + F : LONG_INTEGER; -- N/A => ERROR. + L : LONG_INTEGER; + + FUNCTION IDENT_LONG(A : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN A; + ELSE + RETURN 0; + END IF; + END IDENT_LONG; + + FUNCTION LONG_OK (X : LONG_INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN X = IDENT_LONG(X); + END; + +BEGIN + TEST ( "C45504C", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED WHEN A PRODUCT LIES OUTSIDE THE " & + "RANGE OF THE BASE TYPE, IF THE OPERANDS ARE " & + "OF PREDEFINED TYPE LONG_INTEGER" ); + + F := IDENT_LONG(LONG_INTEGER'FIRST); + L := IDENT_LONG(LONG_INTEGER'LAST); + + BEGIN + IF LONG_OK (F * L) THEN + FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 2" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * L'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'F * L'" ); + END; + + BEGIN + IF LONG_OK (F * F) THEN + FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 2" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * F'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'F * F'" ); + END; + + BEGIN + IF LONG_OK (L * L) THEN + FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 2" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'L * L'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'L * L'" ); + END; + + RESULT; + +END C45504C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45504d.ada b/gcc/testsuite/ada/acats/tests/c4/c45504d.ada new file mode 100644 index 000000000..0b37b13c0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45504d.ada @@ -0,0 +1,214 @@ +-- C45504D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE SECOND +-- OPERAND OF '/', 'MOD', OR 'REM' EQUALS ZERO, IF THE OPERANDS ARE OF +-- PREDEFINED TYPE INTEGER. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- R.WILLIAMS 9/1/86 +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45504D IS + + I0 : INTEGER := IDENT_INT (0); + I5 : INTEGER := IDENT_INT (5); + N5 : INTEGER := IDENT_INT (-5); + +BEGIN + TEST ( "C45504D", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED WHEN THE SECOND OPERAND OF '/', " & + "'MOD', OR 'REM' EQUALS ZERO, IF THE " & + "OPERANDS ARE OF PREDEFINED TYPE INTEGER" ); + + BEGIN + IF I5 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0'" ); + END; + + BEGIN + IF N5 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 / I0'" ); + END; + + BEGIN + IF I0 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 / I0'" ); + END; + + BEGIN + IF I5 / I0 * I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0 * I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0 * I0'" ); + END; + + BEGIN + IF I5 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0'" ); + END; + + BEGIN + IF N5 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 MOD I0'" ); + END; + + BEGIN + IF I0 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 MOD I0'" ); + END; + + BEGIN + IF I5 MOD I0 = (I5 + I0) MOD I0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0'" ); + END; + + BEGIN + IF I5 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM I0'" ); + END; + + BEGIN + IF N5 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 REM I0'" ); + END; + + BEGIN + IF I0 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 REM I0'" ); + END; + + BEGIN + IF I5 REM (-I0) = I5 REM I0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM (-I0) " & + "= I5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0'" ); + END; + + RESULT; +END C45504D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45504e.dep b/gcc/testsuite/ada/acats/tests/c4/c45504e.dep new file mode 100644 index 000000000..8ad4e59e3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45504e.dep @@ -0,0 +1,234 @@ +-- C45504E.DEP + +-- 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 CONSTRAINT_ERROR IS RAISED WHEN THE +-- SECOND OPERAND OF '/', 'MOD', OR 'REM' EQUALS ZERO, IF THE +-- OPERANDS ARE OF PREDEFINED TYPE SHORT_INTEGER. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- SHORT_INTEGER. + +-- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_SHORT" MUST BE REJECTED. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- HISTORY: +-- RJW 09/01/86 CREATED ORIGINAL TEST. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- JRL 03/11/93 INITIALIZED VARIABLES TO DEFEAT OPTIMIZATION. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45504E IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + I0 : SHORT_INTEGER := 1; + I5 : SHORT_INTEGER := 2; + N5 : SHORT_INTEGER := 3; + +BEGIN + TEST ( "C45504E", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED WHEN THE SECOND OPERAND OF '/', " & + "'MOD', OR 'REM' EQUALS ZERO, IF THE " & + "OPERANDS ARE OF PREDEFINED TYPE " & + "SHORT_INTEGER" ); + + IF EQUAL (3, 3) THEN + I0 := 0; + I5 := 5; + N5 := -5; + END IF; + + BEGIN + IF I5 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0'" ); + END; + + BEGIN + IF N5 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 / I0'" ); + END; + + BEGIN + IF I0 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 / I0'" ); + END; + + BEGIN + IF I5 / I0 * I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0 * I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0 * I0'" ); + END; + + BEGIN + IF I5 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0'" ); + END; + + BEGIN + IF N5 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 MOD I0'" ); + END; + + BEGIN + IF I0 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 MOD I0'" ); + END; + + BEGIN + IF I5 MOD I0 = (I5 + I0) MOD I0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0'" ); + END; + + BEGIN + IF I5 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM I0'" ); + END; + + BEGIN + IF N5 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 REM I0'" ); + END; + + BEGIN + IF I0 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 REM I0'" ); + END; + + BEGIN + IF I5 REM (-I0) = I5 REM I0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM (-I0) " & + "= I5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0'" ); + END; + + RESULT; +END C45504E; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45504f.dep b/gcc/testsuite/ada/acats/tests/c4/c45504f.dep new file mode 100644 index 000000000..81ea6c194 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45504f.dep @@ -0,0 +1,234 @@ +-- C45504F.DEP + +-- 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 CONSTRAINT_ERROR IS RAISED WHEN THE +-- SECOND OPERAND OF '/', 'MOD', OR 'REM' EQUALS ZERO, IF THE +-- OPERANDS ARE OF PREDEFINED TYPE LONG_INTEGER. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- LONG_INTEGER. + +-- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_LONG" MUST BE REJECTED. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- HISTORY: +-- RJW 09/01/86 CREATED ORIGINAL TEST. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- JRL 03/11/93 INITIALIZED VARIABLES TO DEFEAT OPTIMIZATION. +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45504F IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + I0 : LONG_INTEGER := 1; + I5 : LONG_INTEGER := 2; + N5 : LONG_INTEGER := 3; + +BEGIN + TEST ( "C45504F", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED WHEN THE SECOND OPERAND OF '/', " & + "'MOD', OR 'REM' EQUALS ZERO, IF THE " & + "OPERANDS ARE OF PREDEFINED TYPE " & + "LONG_INTEGER" ); + + IF EQUAL (3, 3) THEN + I0 := 0; + I5 := 5; + N5 := -5; + END IF; + + BEGIN + IF I5 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0'" ); + END; + + BEGIN + IF N5 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 / I0'" ); + END; + + BEGIN + IF I0 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 / I0'" ); + END; + + BEGIN + IF I5 / I0 * I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0 * I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0 * I0'" ); + END; + + BEGIN + IF I5 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0'" ); + END; + + BEGIN + IF N5 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 MOD I0'" ); + END; + + BEGIN + IF I0 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 MOD I0'" ); + END; + + BEGIN + IF I5 MOD I0 = (I5 + I0) MOD I0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0'" ); + END; + + BEGIN + IF I5 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM I0'" ); + END; + + BEGIN + IF N5 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 REM I0'" ); + END; + + BEGIN + IF I0 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 REM I0'" ); + END; + + BEGIN + IF I5 REM (-I0) = I5 REM I0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM (-I0) " & + "= I5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0'" ); + END; + + RESULT; +END C45504F; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45505a.ada b/gcc/testsuite/ada/acats/tests/c4/c45505a.ada new file mode 100644 index 000000000..747d34b54 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45505a.ada @@ -0,0 +1,65 @@ +-- C45505A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT MULTIPLICATION FOR INTEGER SUBTYPES YIELDS A RESULT +-- BELONGING TO THE BASE TYPE. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X + +-- JBG 2/24/84 +-- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C45505A IS + + TYPE INT IS RANGE 1..10; + + X, Y : INT := INT(IDENT_INT(5)); + +BEGIN + + TEST ("C45505A", "CHECK SUBTYPE OF INTEGER MULTIPLICATION"); + + BEGIN + + IF X * Y / 5 /= INT(IDENT_INT(5)) THEN + FAILED ("INCORRECT RESULT"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + IF INT'BASE'LAST >= INT'VAL(25) THEN + FAILED ("MULTIPLICATION DOES NOT YIELD RESULT " & + "BELONGING TO THE BASE TYPE"); + ELSE + COMMENT ("BASE TYPE HAS RANGE LESS THAN 25"); + END IF; + END; + + RESULT; + +END C45505A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45523a.ada b/gcc/testsuite/ada/acats/tests/c4/c45523a.ada new file mode 100644 index 000000000..ff78eaba7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45523a.ada @@ -0,0 +1,111 @@ +-- C45523A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR FLOATING POINT TYPES, IF MACHINE_OVERFLOWS IS TRUE AND +-- EITHER THE RESULT OF MULTIPLICATION LIES OUTSIDE THE RANGE OF THE +-- BASE TYPE, OR AN ATTEMPT IS MADE TO DIVIDE BY ZERO, THEN +-- CONSTRAINT_ERROR IS RAISED. THIS TESTS +-- DIGITS 5. + + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- HISTORY: +-- BCB 02/09/88 CREATED ORIGINAL TEST. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY +-- KAS 11/14/95 DELETED USAGE OF 'SAFE_LARGE +-- KAS 11/30/95 GOT IT RIGHT THIS TIME + +WITH REPORT; USE REPORT; + +PROCEDURE C45523A IS + + TYPE FLT IS DIGITS 5; + + F : FLT; + + FUNCTION IDENT_FLT(X : FLT) RETURN FLT IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0.0; + END IF; + END IDENT_FLT; + + FUNCTION EQUAL_FLT(ONE, TWO : FLT) RETURN BOOLEAN IS + BEGIN + RETURN ONE = TWO * FLT (IDENT_INT(1)); + END EQUAL_FLT; + +BEGIN + TEST ("C45523A", "FOR FLOATING POINT TYPES, IF MACHINE_" & + "OVERFLOWS IS TRUE AND EITHER THE RESULT OF " & + "MULTIPLICATION LIES OUTSIDE THE RANGE OF THE " & + "BASE TYPE, OR AN ATTEMPT IS MADE TO DIVIDE BY " & + "ZERO, THEN CONSTRAINT_ERROR IS RAISED." & + "THIS TESTS DIGITS 5"); + + + IF FLT'MACHINE_OVERFLOWS THEN + BEGIN + F := (FLT'BASE'LAST) * IDENT_FLT (2.0); + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED FOR MULTIPLICATION"); + IF EQUAL_FLT(F,F**IDENT_INT(1)) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR WAS RAISED FOR " & + "MULTIPLICATION"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN " & + "CONSTRAINT_ERROR WAS RAISED FOR " & + "MULTIPLICATION"); + END; + BEGIN + F := (FLT'LAST) / IDENT_FLT (0.0); + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED FOR DIVISION BY ZERO"); + IF EQUAL_FLT(F,F**IDENT_INT(1)) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR WAS RAISED FOR " & + "DIVISION BY ZERO"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED FOR DIVISION BY ZERO"); + END; + ELSE + NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " & + "MACHINE_OVERFLOWS BEING FALSE"); + END IF; + + RESULT; +END C45523A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531a.ada b/gcc/testsuite/ada/acats/tests/c4/c45531a.ada new file mode 100644 index 000000000..6a77909da --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531a.ada @@ -0,0 +1,182 @@ +-- C45531A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. +-- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45531A IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + +BEGIN TEST ("C45531A", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (0.125); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.125); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + +C: DECLARE + A : INTEGER := 0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_2 (DEL4 * FORTH + DEL1 ); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + +D: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_2 (DEL4 * FORTH + DEL1 ); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + +END C45531A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531b.ada b/gcc/testsuite/ada/acats/tests/c4/c45531b.ada new file mode 100644 index 000000000..74ac115e1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531b.ada @@ -0,0 +1,153 @@ +-- C45531B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. +-- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45531B IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL2 : CONSTANT := 2.0 * DEL1; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + +BEGIN TEST ("C45531B", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (15 * DEL1); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A IS A MODEL NUMBER + A := FX_1 (DEL2 * (3 * FORTH + 1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + +C: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_2 (3 * (DEL4 * FORTH + DEL1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45531B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531c.ada b/gcc/testsuite/ada/acats/tests/c4/c45531c.ada new file mode 100644 index 000000000..a864decdb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531c.ada @@ -0,0 +1,183 @@ +-- C45531C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. +-- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45531C IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45531C", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (2.5); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (FULL_SCALE / 8); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + +C: DECLARE + A : INTEGER := 0; + B : FX_RNG1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_RNG1 (RNG1 * FORTH + 0.5); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + +D: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_RNG1 (RNG1 * FORTH + 0.5); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + +END C45531C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531d.ada b/gcc/testsuite/ada/acats/tests/c4/c45531d.ada new file mode 100644 index 000000000..2c2eb87d1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531d.ada @@ -0,0 +1,153 @@ +-- C45531D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. +-- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45531D IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45531D", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (7.5); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH + 1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (3 * FORTH + 1); -- A MODEL NUMBER + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + +C: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_RNG1 (3 * (RNG1 * FORTH + 0.5) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45531D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531e.ada b/gcc/testsuite/ada/acats/tests/c4/c45531e.ada new file mode 100644 index 000000000..f05ef92c7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531e.ada @@ -0,0 +1,182 @@ +-- C45531E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. +-- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45531E IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + +BEGIN TEST ("C45531E", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (0.125); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.125); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + +C: DECLARE + A : INTEGER := 0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_2 (DEL4 * FORTH + DEL1 ); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + +D: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_2 (DEL4 * FORTH + DEL1 ); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + +END C45531E; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531f.ada b/gcc/testsuite/ada/acats/tests/c4/c45531f.ada new file mode 100644 index 000000000..65b1f1803 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531f.ada @@ -0,0 +1,153 @@ +-- C45531F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. +-- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45531F IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL2 : CONSTANT := 2.0 * DEL1; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + +BEGIN TEST ("C45531F", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (15 * DEL1); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A IS A MODEL NUMBER + A := FX_1 (DEL2 * (3 * FORTH + 1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + +C: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_2 (3 * (DEL4 * FORTH + DEL1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45531F; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531g.ada b/gcc/testsuite/ada/acats/tests/c4/c45531g.ada new file mode 100644 index 000000000..b6146ab64 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531g.ada @@ -0,0 +1,183 @@ +-- C45531G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. +-- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45531G IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45531G", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (2.5); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (FULL_SCALE / 8); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + +C: DECLARE + A : INTEGER := 0; + B : FX_RNG1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_RNG1 (RNG1 * FORTH + 0.5); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + +D: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_RNG1 (RNG1 * FORTH + 0.5); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + +END C45531G; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531h.ada b/gcc/testsuite/ada/acats/tests/c4/c45531h.ada new file mode 100644 index 000000000..e1351582f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531h.ada @@ -0,0 +1,153 @@ +-- C45531H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. +-- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45531H IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45531H", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (7.5); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH + 1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (3 * FORTH + 1); -- A MODEL NUMBER + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + +C: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_RNG1 (3 * (RNG1 * FORTH + 0.5) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45531H; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531i.ada b/gcc/testsuite/ada/acats/tests/c4/c45531i.ada new file mode 100644 index 000000000..ff4765871 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531i.ada @@ -0,0 +1,182 @@ +-- C45531I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. +-- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45531I IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + +BEGIN TEST ("C45531I", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (0.125); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.125); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + +C: DECLARE + A : INTEGER := 0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_2 (DEL4 * FORTH + DEL1 ); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + +D: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_2 (DEL4 * FORTH + DEL1 ); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + +END C45531I; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531j.ada b/gcc/testsuite/ada/acats/tests/c4/c45531j.ada new file mode 100644 index 000000000..7279dd946 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531j.ada @@ -0,0 +1,153 @@ +-- C45531J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. +-- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45531J IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL2 : CONSTANT := 2.0 * DEL1; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + +BEGIN TEST ("C45531J", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (15 * DEL1); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A IS A MODEL NUMBER + A := FX_1 (DEL2 * (3 * FORTH + 1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + +C: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_2 (3 * (DEL4 * FORTH + DEL1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45531J; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531k.ada b/gcc/testsuite/ada/acats/tests/c4/c45531k.ada new file mode 100644 index 000000000..2e70d17e5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531k.ada @@ -0,0 +1,184 @@ +-- C45531K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. +-- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + +WITH REPORT; +PROCEDURE C45531K IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45531K", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (2.5); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (FULL_SCALE / 8); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + +C: DECLARE + A : INTEGER := 0; + B : FX_RNG1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_RNG1 (RNG1 * FORTH + 0.5); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + +D: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_RNG1 (RNG1 * FORTH + 0.5); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + +END C45531K; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531l.ada b/gcc/testsuite/ada/acats/tests/c4/c45531l.ada new file mode 100644 index 000000000..97a6f8d97 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531l.ada @@ -0,0 +1,154 @@ +-- C45531L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. +-- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + +WITH REPORT; +PROCEDURE C45531L IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45531L", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (7.5); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH + 1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (3 * FORTH + 1); -- A MODEL NUMBER + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + +C: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_RNG1 (3 * (RNG1 * FORTH + 0.5) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45531L; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531m.dep b/gcc/testsuite/ada/acats/tests/c4/c45531m.dep new file mode 100644 index 000000000..25ded1fb6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531m.dep @@ -0,0 +1,189 @@ +-- C45531M.DEP + +-- 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 OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. +-- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A +-- 'MAX_MANTISSA OF 47 OR GREATER. + +-- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF +-- 'TYPE FX_OP5' MUST BE REJECTED. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + + +WITH REPORT; +PROCEDURE C45531M IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + -- N/A => ERROR. + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + +BEGIN TEST ("C45531M", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (0.125); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.125); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + +C: DECLARE + A : INTEGER := 0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_2 (DEL4 * FORTH + DEL1 ); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + +D: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_2 (DEL4 * FORTH + DEL1 ); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + +END C45531M; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531n.dep b/gcc/testsuite/ada/acats/tests/c4/c45531n.dep new file mode 100644 index 000000000..f461ba083 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531n.dep @@ -0,0 +1,160 @@ +-- C45531N.DEP + +-- 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 OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. +-- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A +-- 'MAX_MANTISSA OF 47 OR GREATER. + +-- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF +-- 'TYPE FX_OP5' MUST BE REJECTED. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + + +WITH REPORT; +PROCEDURE C45531N IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL2 : CONSTANT := 2.0 * DEL1; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + -- N/A => ERROR. + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + +BEGIN TEST ("C45531N", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (15 * DEL1); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A IS A MODEL NUMBER + A := FX_1 (DEL2 * (3 * FORTH + 1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + +C: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_2 (3 * (DEL4 * FORTH + DEL1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45531N; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531o.dep b/gcc/testsuite/ada/acats/tests/c4/c45531o.dep new file mode 100644 index 000000000..ae8c3953f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531o.dep @@ -0,0 +1,189 @@ +-- C45531O.DEP + +-- 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 OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. +-- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A +-- 'MAX_MANTISSA OF 47 OR GREATER. + +-- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF +-- 'TYPE FX_OP5' MUST BE REJECTED. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + +WITH REPORT; +PROCEDURE C45531O IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + -- N/A => ERROR. + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45531O", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (2.5); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (FULL_SCALE / 8); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + +C: DECLARE + A : INTEGER := 0; + B : FX_RNG1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_RNG1 (RNG1 * FORTH + 0.5); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + +D: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_RNG1 (RNG1 * FORTH + 0.5); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + +END C45531O; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45531p.dep b/gcc/testsuite/ada/acats/tests/c4/c45531p.dep new file mode 100644 index 000000000..e4b6ce967 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531p.dep @@ -0,0 +1,159 @@ +-- C45531P.DEP + +-- 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 OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. +-- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. +-- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A +-- 'MAX_MANTISSA OF 47 OR GREATER. + +-- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF +-- 'TYPE FX_OP5' MUST BE REJECTED. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + +WITH REPORT; +PROCEDURE C45531P IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + -- N/A => ERROR. + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45531P", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (7.5); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + +B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH + 1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (3 * FORTH + 1); -- A MODEL NUMBER + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + +C: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_RNG1 (3 * (RNG1 * FORTH + 0.5) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45531P; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532a.ada b/gcc/testsuite/ada/acats/tests/c4/c45532a.ada new file mode 100644 index 000000000..8ebbc0a37 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532a.ada @@ -0,0 +1,152 @@ +-- C45532A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. +-- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. +-- C) THE OPERATOR *, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45532A IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + +BEGIN TEST ("C45532A", "FIXED POINT OPERATOR ""*"" " + & "FOR RANGE <, =, AND > 1.0"); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.25); -- A MODEL NUMBER + B := FX_2 (0.50); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + +B: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 64; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_1 (DEL1 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 128 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 128 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (DEL1 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (DEL1 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532b.ada b/gcc/testsuite/ada/acats/tests/c4/c45532b.ada new file mode 100644 index 000000000..5077477f3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532b.ada @@ -0,0 +1,159 @@ +-- C45532B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. +-- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. +-- C) THE OPERATOR /, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45532B IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; -- MUST BE EVEN & >= 6 + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + A_THIRD : CONSTANT := FULL_SCALE / 3; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. + 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. + 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. + 2.0 - DEL1 * 4; + +BEGIN TEST ("C45532B", "FIXED POINT OPERATOR ""/"" " + & "FOR RANGE <, =, AND > 1.0"); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + HIGHEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.125); -- A MODEL NUMBER + B := FX_1 (0.25); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + +B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * 1); -- A MODEL NUMBER + B := FX_0P5 (DEL1 * 3); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOW_COUNT : CONSTANT := 2 * A_THIRD; + -- := (2 * FULL_SCALE * (2 * FORTH + 0)) + -- / (6 * FORTH + 2); + HIGH_COUNT : CONSTANT := 2 * A_THIRD + 4; + -- := (2 * FULL_SCALE * (2 * FORTH + 2)) + -- / (6 * FORTH + 0); + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * HIGH_COUNT ); + BEGIN + IF EQUAL (3, 3) THEN -- A AND B NOT MODEL NUMBERS + A := FX_1 (DEL1 * (2 * FORTH + 1)); + B := FX_1 (DEL1 * (6 * FORTH + 1)); + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532c.ada b/gcc/testsuite/ada/acats/tests/c4/c45532c.ada new file mode 100644 index 000000000..9e9aaa292 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532c.ada @@ -0,0 +1,156 @@ +-- C45532C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. +-- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. +-- C) THE OPERATOR *, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45532C IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45532C", "FIXED POINT OPERATOR ""*"" " + & "FOR DELTA <, =, AND > 1.0"); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + HIGHEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + B := FX_1 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + +B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 16; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.5 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_0P5 (0.5 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 32 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 32 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.5 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (0.5 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532d.ada b/gcc/testsuite/ada/acats/tests/c4/c45532d.ada new file mode 100644 index 000000000..51923df95 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532d.ada @@ -0,0 +1,150 @@ +-- C45532D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. +-- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. +-- C) THE OPERATOR /, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45532D IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + A_THIRD : CONSTANT := FULL_SCALE / 3; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45532D", "FIXED POINT OPERATOR ""/"" " + & "FOR DELTA <, =, AND > 1.0"); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_RNG1 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 4); -- A MODEL NUMBER + B := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + +B: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1); -- A MODEL NUMBER + B := FX_1 (3.0); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 - 3.0); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 + 4.0); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 3); -- NOT A MODEL NUMBER + B := FX_1 (RNG1 / 3); -- NOT A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532e.ada b/gcc/testsuite/ada/acats/tests/c4/c45532e.ada new file mode 100644 index 000000000..42989f162 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532e.ada @@ -0,0 +1,151 @@ +-- C45532E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. +-- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. +-- C) THE OPERATOR *, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45532E IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + +BEGIN TEST ("C45532E", "FIXED POINT OPERATOR ""*""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.25); -- A MODEL NUMBER + B := FX_2 (0.50); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + +B: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 64; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_1 (DEL1 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 128 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 128 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (DEL1 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (DEL1 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532E; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532f.ada b/gcc/testsuite/ada/acats/tests/c4/c45532f.ada new file mode 100644 index 000000000..59a9e25bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532f.ada @@ -0,0 +1,158 @@ +-- C45532F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. +-- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. +-- C) THE OPERATOR /, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45532F IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; -- MUST BE EVEN & >= 6 + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + A_THIRD : CONSTANT := FULL_SCALE / 3; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. + 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. + 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. + 2.0 - DEL1 * 4; + +BEGIN TEST ("C45532F", "FIXED POINT OPERATOR ""/""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + HIGHEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.125); -- A MODEL NUMBER + B := FX_1 (0.25); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + +B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * 1); -- A MODEL NUMBER + B := FX_0P5 (DEL1 * 3); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOW_COUNT : CONSTANT := 2 * A_THIRD; + -- := (2 * FULL_SCALE * (2 * FORTH + 0)) + -- / (6 * FORTH + 2); + HIGH_COUNT : CONSTANT := 2 * A_THIRD + 4; + -- := (2 * FULL_SCALE * (2 * FORTH + 2)) + -- / (6 * FORTH + 0); + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * HIGH_COUNT ); + BEGIN + IF EQUAL (3, 3) THEN -- A AND B NOT MODEL NUMBERS + A := FX_1 (DEL1 * (2 * FORTH + 1)); + B := FX_1 (DEL1 * (6 * FORTH + 1)); + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532F; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532g.ada b/gcc/testsuite/ada/acats/tests/c4/c45532g.ada new file mode 100644 index 000000000..c9d8f004d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532g.ada @@ -0,0 +1,155 @@ +-- C45532G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. +-- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. +-- C) THE OPERATOR *, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45532G IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45532G", "FIXED POINT OPERATOR ""*""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + HIGHEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + B := FX_1 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + +B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 16; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.5 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_0P5 (0.5 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 32 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 32 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.5 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (0.5 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532G; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532h.ada b/gcc/testsuite/ada/acats/tests/c4/c45532h.ada new file mode 100644 index 000000000..ea1d9613f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532h.ada @@ -0,0 +1,149 @@ +-- C45532H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. +-- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. +-- C) THE OPERATOR /, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45532H IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + A_THIRD : CONSTANT := FULL_SCALE / 3; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45532H", "FIXED POINT OPERATOR ""/""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_RNG1 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 4); -- A MODEL NUMBER + B := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + +B: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1); -- A MODEL NUMBER + B := FX_1 (3.0); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 - 3.0); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 + 4.0); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 3); -- NOT A MODEL NUMBER + B := FX_1 (RNG1 / 3); -- NOT A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532H; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532i.ada b/gcc/testsuite/ada/acats/tests/c4/c45532i.ada new file mode 100644 index 000000000..60a7dfe18 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532i.ada @@ -0,0 +1,152 @@ +-- C45532I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. +-- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. +-- C) THE OPERATOR *, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + +WITH REPORT; +PROCEDURE C45532I IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + +BEGIN TEST ("C45532I", "FIXED POINT OPERATOR ""*""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.25); -- A MODEL NUMBER + B := FX_2 (0.50); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + +B: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 64; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_1 (DEL1 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 128 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 128 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (DEL1 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (DEL1 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532I; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532j.ada b/gcc/testsuite/ada/acats/tests/c4/c45532j.ada new file mode 100644 index 000000000..a50906c46 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532j.ada @@ -0,0 +1,158 @@ +-- C45532J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. +-- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. +-- C) THE OPERATOR /, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + +WITH REPORT; +PROCEDURE C45532J IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; -- MUST BE EVEN & >= 6 + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + A_THIRD : CONSTANT := FULL_SCALE / 3; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. + 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. + 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. + 2.0 - DEL1 * 4; + +BEGIN TEST ("C45532J", "FIXED POINT OPERATOR ""/""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + HIGHEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.125); -- A MODEL NUMBER + B := FX_1 (0.25); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + +B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * 1); -- A MODEL NUMBER + B := FX_0P5 (DEL1 * 3); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOW_COUNT : CONSTANT := 2 * A_THIRD; + -- := (2 * FULL_SCALE * (2 * FORTH + 0)) + -- / (6 * FORTH + 2); + HIGH_COUNT : CONSTANT := 2 * A_THIRD + 4; + -- := (2 * FULL_SCALE * (2 * FORTH + 2)) + -- / (6 * FORTH + 0); + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * HIGH_COUNT ); + BEGIN + IF EQUAL (3, 3) THEN -- A AND B NOT MODEL NUMBERS + A := FX_1 (DEL1 * (2 * FORTH + 1)); + B := FX_1 (DEL1 * (6 * FORTH + 1)); + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532J; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532k.ada b/gcc/testsuite/ada/acats/tests/c4/c45532k.ada new file mode 100644 index 000000000..1f2bd7102 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532k.ada @@ -0,0 +1,156 @@ +-- C45532K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. +-- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. +-- C) THE OPERATOR *, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + +WITH REPORT; +PROCEDURE C45532K IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45532K", "FIXED POINT OPERATOR ""*""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + HIGHEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + B := FX_1 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + +B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 16; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.5 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_0P5 (0.5 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 32 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 32 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.5 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (0.5 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532K; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532l.ada b/gcc/testsuite/ada/acats/tests/c4/c45532l.ada new file mode 100644 index 000000000..2ea7fea82 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532l.ada @@ -0,0 +1,150 @@ +-- C45532L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. +-- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. +-- C) THE OPERATOR /, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. +-- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR +-- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + +WITH REPORT; +PROCEDURE C45532L IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + A_THIRD : CONSTANT := FULL_SCALE / 3; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45532L", "FIXED POINT OPERATOR ""/""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_RNG1 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 4); -- A MODEL NUMBER + B := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + +B: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1); -- A MODEL NUMBER + B := FX_1 (3.0); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 - 3.0); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 + 4.0); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 3); -- NOT A MODEL NUMBER + B := FX_1 (RNG1 / 3); -- NOT A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532L; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532m.dep b/gcc/testsuite/ada/acats/tests/c4/c45532m.dep new file mode 100644 index 000000000..b4001af93 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532m.dep @@ -0,0 +1,157 @@ +-- C45532M.DEP + +-- 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 OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. +-- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. +-- C) THE OPERATOR *, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A +-- 'MAX_MANTISSA OF 47 OR GREATER. + +-- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF +-- 'TYPE FX_OP5' MUST BE REJECTED. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + +WITH REPORT; +PROCEDURE C45532M IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + -- N/A => ERROR. + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + +BEGIN TEST ("C45532M", "FIXED POINT OPERATOR ""*""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.25); -- A MODEL NUMBER + B := FX_2 (0.50); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + +B: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 64; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_1 (DEL1 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 128 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 128 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (DEL1 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (DEL1 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532M; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532n.dep b/gcc/testsuite/ada/acats/tests/c4/c45532n.dep new file mode 100644 index 000000000..9315c6826 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532n.dep @@ -0,0 +1,163 @@ +-- C45532N.DEP + +-- 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 OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. +-- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. +-- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. +-- C) THE OPERATOR /, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A +-- 'MAX_MANTISSA OF 47 OR GREATER. + +-- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF +-- 'TYPE FX_OP5' MUST BE REJECTED. + + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + +WITH REPORT; +PROCEDURE C45532N IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; -- MUST BE EVEN & >= 6 + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + A_THIRD : CONSTANT := FULL_SCALE / 3; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. + 0.5 - DEL1 * 1; -- N/A => ERROR. + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. + 1.0 - DEL1 * 2; -- N/A => ERROR. + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. + 2.0 - DEL1 * 4; -- N/A => ERROR. + +BEGIN TEST ("C45532N", "FIXED POINT OPERATOR ""/""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + HIGHEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.125); -- A MODEL NUMBER + B := FX_1 (0.25); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + +B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * 1); -- A MODEL NUMBER + B := FX_0P5 (DEL1 * 3); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOW_COUNT : CONSTANT := 2 * A_THIRD; + -- := (2 * FULL_SCALE * (2 * FORTH + 0)) + -- / (6 * FORTH + 2); + HIGH_COUNT : CONSTANT := 2 * A_THIRD + 4; + -- := (2 * FULL_SCALE * (2 * FORTH + 2)) + -- / (6 * FORTH + 0); + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * HIGH_COUNT ); + BEGIN + IF EQUAL (3, 3) THEN -- A AND B NOT MODEL NUMBERS + A := FX_1 (DEL1 * (2 * FORTH + 1)); + B := FX_1 (DEL1 * (6 * FORTH + 1)); + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532N; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532o.dep b/gcc/testsuite/ada/acats/tests/c4/c45532o.dep new file mode 100644 index 000000000..b0126df4b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532o.dep @@ -0,0 +1,161 @@ +-- C45532O.DEP + +-- 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 OPERATOR "*" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. +-- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. +-- C) THE OPERATOR *, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A +-- 'MAX_MANTISSA OF 47 OR GREATER. + +-- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF +-- 'TYPE FX_OP5' MUST BE REJECTED. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + +WITH REPORT; +PROCEDURE C45532O IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + -- N/A => ERROR. + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45532O", "FIXED POINT OPERATOR ""*""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + HIGHEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + B := FX_1 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + +B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 16; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.5 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_0P5 (0.5 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 32 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 32 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.5 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (0.5 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532O; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45532p.dep b/gcc/testsuite/ada/acats/tests/c4/c45532p.dep new file mode 100644 index 000000000..cab503166 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532p.dep @@ -0,0 +1,155 @@ +-- C45532P.DEP + +-- 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 OPERATOR "/" PRODUCES CORRECT RESULTS +-- FOR FIXED POINT TYPES USING 3 SUBTESTS. +-- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. +-- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR +-- EQUAL TO 0.5. +-- +-- TEST CASES ARE: +-- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. +-- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. +-- C) THE OPERATOR /, USING NO MODEL NUMBERS. +-- +-- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, +-- WITH RANGE <, =, AND > THAN 1.0 AND +-- WITH DELTA <, =, AND > THAN 1.0. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A +-- 'MAX_MANTISSA OF 47 OR GREATER. + +-- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF +-- 'TYPE FX_OP5' MUST BE REJECTED. + +-- HISTORY: +-- NTW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/05/86 REVISED COMMENTS. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + +WITH REPORT; +PROCEDURE C45532P IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + A_THIRD : CONSTANT := FULL_SCALE / 3; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + -- N/A => ERROR. + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + +BEGIN TEST ("C45532P", "FIXED POINT OPERATOR ""/""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + +A: DECLARE + A : FX_RNG1 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 4); -- A MODEL NUMBER + B := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + +B: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1); -- A MODEL NUMBER + B := FX_1 (3.0); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + +C: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 - 3.0); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 + 4.0); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 3); -- NOT A MODEL NUMBER + B := FX_1 (RNG1 / 3); -- NOT A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + +END C45532P; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45534b.ada b/gcc/testsuite/ada/acats/tests/c4/c45534b.ada new file mode 100644 index 000000000..6c087c3fa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45534b.ada @@ -0,0 +1,105 @@ +-- C45534B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN A +-- FIXED POINT VALUE IS DIVIDED BY ZERO (EITHER AN INTEGER ZERO OR +-- A FIXED POINT ZERO). + + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- HISTORY: +-- BCB 07/14/88 CREATED ORIGINAL TEST. +-- MRM 03/30/93 REMOVED NUMERIC ERROR FOR 9X CONSISTENCY + +WITH REPORT; USE REPORT; + +PROCEDURE C45534B IS + + TYPE FIX IS DELTA 2.0**(-1) RANGE -2.0 .. 2.0; + TYPE FIX2 IS DELTA 2.0**(-1) RANGE -3.0 .. 3.0; + + A : FIX := 1.0; + B : FIX; + ZERO : FIX := 0.0; + ZERO2 : FIX2 := 0.0; + + FUNCTION IDENT_FLT (ONE, TWO : FIX) RETURN BOOLEAN IS + BEGIN + RETURN ONE = FIX (TWO * FIX (IDENT_INT(1))); + END IDENT_FLT; + +BEGIN + TEST ("C45534B", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "A FIXED POINT VALUE IS " & + "DIVIDED BY ZERO (EITHER AN INTEGER ZERO OR A " & + "FIXED POINT ZERO)"); + + BEGIN + B := A / IDENT_INT (0); + FAILED ("NO EXCEPTION RAISED FOR DIVISION BY INTEGER ZERO"); + IF IDENT_FLT (B,B) THEN + COMMENT ("DON'T OPTIMIZE B"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + BEGIN + B := FIX (A / ZERO); + FAILED ("NO EXCEPTION RAISED FOR DIVISION BY FIXED POINT " & + "ZERO - 1"); + IF IDENT_FLT (B,B) THEN + COMMENT ("DON'T OPTIMIZE B"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + BEGIN + B := FIX (A / ZERO2); + FAILED ("NO EXCEPTION RAISED FOR DIVISION BY FIXED POINT " & + "ZERO - 2"); + IF IDENT_FLT (B,B) THEN + COMMENT ("DON'T OPTIMIZE B"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + RESULT; +END C45534B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45536a.dep b/gcc/testsuite/ada/acats/tests/c4/c45536a.dep new file mode 100644 index 000000000..760d43011 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45536a.dep @@ -0,0 +1,158 @@ +-- C45536A.DEP + +-- 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 FIXED POINT MULTIPLICATION AND DIVISION WHEN 'SMALL OF +-- THE OPERANDS ARE NOT BOTH POWERS OF THE SAME BASE VALUE. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT +-- REPRESENTATION CLAUSES FOR 'SMALL WHICH ARE NOT POWERS OF TWO. + +-- IF SUCH REPRESENTATION CLAUSES ARE NOT SUPPORTED, THEN THE +-- REPRESENTATION CLAUSE FOR CHECK_TYPE MUST BE REJECTED. + +-- HISTORY: +-- BCB 02/02/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C45536A IS + + TYPE CHECK_TYPE IS DELTA 2.0**(-1) RANGE 0.0 .. 8.0; + FOR CHECK_TYPE'SMALL USE 0.2; -- N/A => ERROR. + + TYPE F1 IS DELTA 2.0**(-1) RANGE 0.0 .. 8.0; + FOR F1'SMALL USE 0.5; + + TYPE F2 IS DELTA 2.0**(-1) RANGE 0.0 .. 8.0; + FOR F2'SMALL USE 0.2; + + TYPE F3 IS DELTA 2.0**(-1) RANGE 0.0 .. 8.0; + FOR F3'SMALL USE 0.1; + + A : F1; + B : F2; + C : F3; + + FUNCTION IDENT_FIX(X : F3) RETURN F3 IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0.0; + END IF; + END IDENT_FIX; + +BEGIN + TEST ("C45536A", "CHECK FIXED POINT MULTIPLICATION AND DIVISION " & + "WHEN 'SMALL OF THE OPERANDS ARE NOT BOTH " & + "POWERS OF THE SAME BASE VALUE"); + + A := 1.0; B := 1.0; C := F3(A * B); + + IF C /= IDENT_FIX(1.0) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 1"); + END IF; + + C := F3(A / B); + + IF C /= IDENT_FIX(1.0) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 1"); + END IF; + + A := 1.0; B := 0.3; C := F3(A * B); + + IF C NOT IN IDENT_FIX(0.2) .. IDENT_FIX(0.4) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 2"); + END IF; + + B := 0.25; C := F3(A / B); + + IF C NOT IN IDENT_FIX(2.5) .. IDENT_FIX(5.0) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 2"); + END IF; + + A := 0.5; B := 0.3; C := F3(A * B); + + IF C NOT IN IDENT_FIX(0.1) .. IDENT_FIX(0.2) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 3"); + END IF; + + C := F3(A / B); + + IF C NOT IN IDENT_FIX(1.2) .. IDENT_FIX(2.5) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 3"); + END IF; + + B := 0.3; C := 0.2; A := F1(B * C); + + IF A NOT IN F1(IDENT_FIX(0.0)) .. F1(IDENT_FIX(0.5)) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 4"); + END IF; + + A := 1.0; B := 1.6; C := F3(A / B); + + IF C NOT IN IDENT_FIX(0.6) .. IDENT_FIX(0.7) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 4"); + END IF; + + A := 0.75; B := 0.4; C := F3(A * B); + + IF C NOT IN IDENT_FIX(0.2) .. IDENT_FIX(0.4) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 5"); + END IF; + + A := 0.8; C := F3(A / B); + + IF C NOT IN IDENT_FIX(1.2) .. IDENT_FIX(2.5) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 5"); + END IF; + + A := 0.8; B := 0.4; C := F3(A * B); + + IF C NOT IN IDENT_FIX(0.2) .. IDENT_FIX(0.4) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 6"); + END IF; + + A := 0.75; C := F3(A / B); + + IF C NOT IN IDENT_FIX(1.2) .. IDENT_FIX(2.5) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 6"); + END IF; + + A := 0.7; B := 0.3; C := F3(A * B); + + IF C NOT IN IDENT_FIX(0.1) .. IDENT_FIX(0.4) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 7"); + END IF; + + C := F3(A / B); + + IF C NOT IN IDENT_FIX(1.2) .. IDENT_FIX(5.0) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 7"); + END IF; + + RESULT; +END C45536A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c456001.a b/gcc/testsuite/ada/acats/tests/c4/c456001.a new file mode 100644 index 000000000..9062f93fc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c456001.a @@ -0,0 +1,91 @@ +-- C456001.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +-- +-- Notice +-- +-- The ACAA has created and maintains the Ada Conformity Assessment Test +-- Suite for the purpose of conformity assessments conducted in accordance +-- with the International Standard ISO/IEC 18009 - Ada: Conformity +-- assessment of a language processor. This test suite should not be used +-- to make claims of conformance unless used in accordance with +-- ISO/IEC 18009 and any applicable ACAA procedures. +-- +--* +-- OBJECTIVE: +-- For exponentiation of floating point types, check that +-- Constraint_Error is raised (or, if no exception is raised and +-- Machine_Overflows is False, that a result is produced) if the +-- result is outside of the range of the base type. +-- This tests digits 5. + +-- HISTORY: +-- 04/30/03 RLB Created test from old C45622A and C45624A. + +with Report; + +procedure C456001 is + + type Flt is digits 5; + + F : Flt; + + function Equal_Flt (One, Two : Flt) return Boolean is + -- Break optimization. + begin + return One = Two * Flt (Report.Ident_Int(1)); + end Equal_Flt; + +begin + Report.Test ("C456001", "For exponentiation of floating point types, " & + "check that Constraint_Error is raised (or, if " & + "if no exception is raised and Machine_Overflows is " & + "False, that a result is produced) if the result is " & + "outside of the range of the base type."); + + begin + F := (Flt'Base'Last)**Report.Ident_Int (2); + if Flt'Machine_Overflows Then + Report.Failed ("Constraint_Error was not raised for " & + "exponentiation"); + else + -- RM95 3.5.6(7) allows disobeying RM95 4.5(10) if + -- Machine_Overflows is False. + Report.Comment ("Constraint_Error was not raised for " & + "exponentiation and Machine_Overflows is False"); + end if; + if not Equal_Flt (F, F) then + -- Optimization breaker, F must be evaluated. + Report.Comment ("Don't optimize F"); + end if; + exception + when Constraint_Error => + Report.Comment ("Constraint_Error was raised for " & + "exponentiation"); + when others => + Report.Failed ("An exception other than Constraint_Error " & + "was raised for exponentiation"); + end; + + Report.Result; +end C456001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45611a.ada b/gcc/testsuite/ada/acats/tests/c4/c45611a.ada new file mode 100644 index 000000000..3f7a690fb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45611a.ada @@ -0,0 +1,123 @@ +-- C45611A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT EXPONENTIATION OF AN INTEGER TO AN INTEGER VALUE IS +-- CORRECTLY EVALUATED. + +-- H. TILTON 9/23/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C45611A IS + + I1,INT : INTEGER; + + BEGIN + + + TEST ("C45611A", "CHECK THAT EXPONENTIATION OF AN INTEGER " & + "VALUE IS CORRECTLY EVALUATED"); + + I1 := IDENT_INT(0) ** IDENT_INT(0); + + IF IDENT_INT(I1) /= IDENT_INT(1) THEN + FAILED( "INCORRECT RESULT FOR '0**0'" ); + END IF; + + INT := "**" (IDENT_INT(0),IDENT_INT(1)); + + IF IDENT_INT(INT) /= IDENT_INT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**1'" ); + END IF; + + I1 := IDENT_INT(6) ** IDENT_INT(0); + + IF IDENT_INT(I1) /= IDENT_INT(1) THEN + FAILED( "INCORRECT RESULT FOR '6**0'" ); + END IF; + + INT := IDENT_INT(156) ** IDENT_INT(1); + + IF IDENT_INT(INT) /= IDENT_INT(156) THEN + FAILED( "INCORRECT RESULT FOR '156**1'" ); + END IF; + + I1 := IDENT_INT(-3) ** IDENT_INT(0); + + IF IDENT_INT(I1) /= IDENT_INT(1) THEN + FAILED( "INCORRECT RESULT FOR '(-3)**0'" ); + END IF; + + INT := "**" (IDENT_INT(-7),IDENT_INT(1)); + + IF IDENT_INT(INT) /= IDENT_INT(-7) THEN + FAILED( "INCORRECT RESULT FOR '(-7)**1'" ); + END IF; + + I1 := "**" (IDENT_INT(-1),IDENT_INT(2)); + + IF IDENT_INT(I1) /= IDENT_INT(1) THEN + FAILED( "INCORRECT RESULT FOR '(-1)**2'" ); + END IF; + + + INT := IDENT_INT(-1) ** 3; + + IF IDENT_INT(INT) /= IDENT_INT(-1) THEN + FAILED( "INCORRECT RESULT FOR '(-1)**3'" ); + END IF; + + INT := "**" (IDENT_INT(0),IDENT_INT(2)); + + IF IDENT_INT(INT) /= IDENT_INT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**2'" ); + END IF; + + INT := IDENT_INT(0) ** IDENT_INT(10); + + IF IDENT_INT(INT) /= IDENT_INT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**10'" ); + END IF; + + INT := "**" (IDENT_INT(6),IDENT_INT(2)); + + IF IDENT_INT(INT) /= IDENT_INT(36) THEN + FAILED( "INCORRECT RESULT FOR '6**2'" ); + END IF; + + INT := "**" (IDENT_INT(2),IDENT_INT(2)); + + IF IDENT_INT(INT) /= IDENT_INT(4) THEN + FAILED( "INCORRECT RESULT FOR '2**2'" ); + END IF; + + I1 := "**" (IDENT_INT(1),IDENT_INT(10)); + + IF IDENT_INT(I1) /= IDENT_INT(1) THEN + FAILED( "INCORRECT RESULT FOR '1**10'" ); + END IF; + + RESULT; + + END C45611A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45611b.dep b/gcc/testsuite/ada/acats/tests/c4/c45611b.dep new file mode 100644 index 000000000..fb63ef82e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45611b.dep @@ -0,0 +1,141 @@ +-- C45611B.DEP + +-- 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 EXPONENTIATION OF A SHORT_INTEGER TO AN INTEGER VALUE +-- IS CORRECTLY EVALUATED. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- SHORT_INTEGER. + +-- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_SHORT" MUST BE REJECTED. + +-- HISTORY: +-- HTG 09/23/86 CREATED ORIGINAL TEST. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + +WITH REPORT; USE REPORT; + +PROCEDURE C45611B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + I1,INT : SHORT_INTEGER; + + FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + + + TEST ("C45611B", "CHECK THAT EXPONENTIATION OF A " & + "SHORT_INTEGER VALUE IS CORRECTLY " & + "EVALUATED"); + + I1 := IDENT(0) ** IDENT_INT(0); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '0**0'" ); + END IF; + + INT := "**" (IDENT(0),IDENT_INT(1)); + + IF IDENT(INT) /= IDENT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**1'" ); + END IF; + + I1 := IDENT(6) ** IDENT_INT(0); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '6**0'" ); + END IF; + + INT := IDENT(15) ** IDENT_INT(1); + + IF IDENT(INT) /= IDENT(15) THEN + FAILED( "INCORRECT RESULT FOR '15**1'" ); + END IF; + + I1 := IDENT(-3) ** IDENT_INT(0); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '(-3)**0'" ); + END IF; + + INT := "**" (IDENT(-7),IDENT_INT(1)); + + IF IDENT(INT) /= IDENT(-7) THEN + FAILED( "INCORRECT RESULT FOR '(-7)**1'" ); + END IF; + + I1 := "**" (IDENT(-1),IDENT_INT(2)); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '(-1)**2'" ); + END IF; + + + INT := IDENT(-1) ** IDENT_INT(3); + + IF IDENT(INT) /= IDENT(-1) THEN + FAILED( "INCORRECT RESULT FOR '(-1)**3'" ); + END IF; + + INT := "**" (IDENT(0),IDENT_INT(2)); + + IF IDENT(INT) /= IDENT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**2'" ); + END IF; + + INT := IDENT(0) ** IDENT_INT(10); + + IF IDENT(INT) /= IDENT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**10'" ); + END IF; + + INT := "**" (IDENT(6),IDENT_INT(2)); + + IF IDENT(INT) /= IDENT(36) THEN + FAILED( "INCORRECT RESULT FOR '6**2'" ); + END IF; + + INT := "**" (IDENT(2),IDENT_INT(2)); + + IF IDENT(INT) /= IDENT(4) THEN + FAILED( "INCORRECT RESULT FOR '2**2'" ); + END IF; + + I1 := "**" (IDENT(1),IDENT_INT(10)); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '1**10'" ); + END IF; + + RESULT; + + END C45611B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45611c.dep b/gcc/testsuite/ada/acats/tests/c4/c45611c.dep new file mode 100644 index 000000000..0687d3a48 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45611c.dep @@ -0,0 +1,141 @@ +-- C45611C.DEP + +-- 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 EXPONENTIATION OF A LONG_INTEGER TO AN INTEGER VALUE +-- IS CORRECTLY EVALUATED. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- LONG_INTEGER. + +-- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_LONG" MUST BE REJECTED. + +-- HISTORY: +-- HTG 09/23/86 CREATED ORIGINAL TEST. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + +WITH REPORT; USE REPORT; + +PROCEDURE C45611C IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + I1,INT : LONG_INTEGER; + + FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + RETURN LONG_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + + + TEST ("C45611C", "CHECK THAT EXPONENTIATION OF A " & + "LONG_INTEGER VALUE IS CORRECTLY " & + "EVALUATED"); + + I1 := IDENT(0) ** IDENT_INT(0); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '0**0'" ); + END IF; + + INT := "**" (IDENT(0),IDENT_INT(1)); + + IF IDENT(INT) /= IDENT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**1'" ); + END IF; + + I1 := IDENT(6) ** IDENT_INT(0); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '6**0'" ); + END IF; + + INT := IDENT(156) ** IDENT_INT(1); + + IF IDENT(INT) /= IDENT(156) THEN + FAILED( "INCORRECT RESULT FOR '156**1'" ); + END IF; + + I1 := IDENT(-3) ** IDENT_INT(0); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '(-3)**0'" ); + END IF; + + INT := "**" (IDENT(-7),IDENT_INT(1)); + + IF IDENT(INT) /= IDENT(-7) THEN + FAILED( "INCORRECT RESULT FOR '(-7)**1'" ); + END IF; + + I1 := "**" (IDENT(-1),IDENT_INT(2)); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '(-1)**2'" ); + END IF; + + + INT := IDENT(-1) ** IDENT_INT(3); + + IF IDENT(INT) /= IDENT(-1) THEN + FAILED( "INCORRECT RESULT FOR '(-1)**3'" ); + END IF; + + INT := "**" (IDENT(0),IDENT_INT(2)); + + IF IDENT(INT) /= IDENT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**2'" ); + END IF; + + INT := IDENT(0) ** IDENT_INT(10); + + IF IDENT(INT) /= IDENT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**10'" ); + END IF; + + INT := "**" (IDENT(6),IDENT_INT(2)); + + IF IDENT(INT) /= IDENT(36) THEN + FAILED( "INCORRECT RESULT FOR '6**2'" ); + END IF; + + INT := "**" (IDENT(2),IDENT_INT(2)); + + IF IDENT(INT) /= IDENT(4) THEN + FAILED( "INCORRECT RESULT FOR '2**2'" ); + END IF; + + I1 := "**" (IDENT(1),IDENT_INT(10)); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '1**10'" ); + END IF; + + RESULT; + + END C45611C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45613a.ada b/gcc/testsuite/ada/acats/tests/c4/c45613a.ada new file mode 100644 index 000000000..b539018bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45613a.ada @@ -0,0 +1,79 @@ +-- C45613A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED +-- BY "**" FOR INTEGERS WHEN THE RESULT EXCEEDS THE RANGE +-- OF THE BASE TYPE. + + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- H. TILTON 10/06/86 +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; +PROCEDURE C45613A IS + +BEGIN + TEST ("C45613A","CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED BY ""**"" FOR INTEGERS WHEN THE " & + "RESULT EXCEEDS THE RANGE OF THE BASE TYPE"); + + DECLARE + INT : INTEGER; + BEGIN + INT := IDENT_INT(INTEGER'LAST ** IDENT_INT(2)); + FAILED ("NO EXCEPTION FOR SECOND POWER OF INTEGER'LAST"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "SECOND POWER OF " & + "INTEGER'LAST"); + END; + + DECLARE + INT : INTEGER; + BEGIN + INT := IDENT_INT(INTEGER'FIRST ** IDENT_INT(3)); + FAILED ("NO EXCEPTION FOR THIRD POWER OF INTEGER'FIRST"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "THIRD POWER OF " & + "INTEGER'FIRST"); + + END; + + RESULT; + +END C45613A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45613b.dep b/gcc/testsuite/ada/acats/tests/c4/c45613b.dep new file mode 100644 index 000000000..4ce07cd9d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45613b.dep @@ -0,0 +1,97 @@ +-- C45613B.DEP + +-- 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 CONSTRAINT_ERROR IS RAISED +-- BY "**" FOR SHORT_INTEGER WHEN THE RESULT EXCEEDS THE RANGE +-- OF THE BASE TYPE. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- SHORT_INTEGER. + +-- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_SHORT" MUST BE REJECTED. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- HISTORY: +-- HTG 10/06/86 CREATED ORIGINAL TEST. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; +PROCEDURE C45613B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + +BEGIN + TEST ("C45613B","CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED BY ""**"" FOR SHORT_INTEGER WHEN " & + "THE RESULT EXCEEDS THE RANGE OF THE BASE TYPE"); + + DECLARE + INT : SHORT_INTEGER; + BEGIN + INT := IDENT(SHORT_INTEGER'LAST ** IDENT_INT(2)); + FAILED ("NO EXCEPTION FOR SECOND POWER OF " & + "SHORT_INTEGER'LAST"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "SECOND POWER OF " & + "SHORT_INTEGER'LAST"); + END; + + DECLARE + INT : SHORT_INTEGER; + BEGIN + INT := IDENT(SHORT_INTEGER'FIRST ** IDENT_INT(3)); + FAILED ("NO EXCEPTION FOR THIRD POWER OF " & + "SHORT_INTEGER'FIRST"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "THIRD POWER OF " & + "SHORT_INTEGER'FIRST"); + + END; + + RESULT; + +END C45613B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45613c.dep b/gcc/testsuite/ada/acats/tests/c4/c45613c.dep new file mode 100644 index 000000000..074d2b352 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45613c.dep @@ -0,0 +1,97 @@ +-- C45613C.DEP + +-- 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 CONSTRAINT_ERROR IS RAISED +-- BY "**" FOR LONG_INTEGER WHEN THE RESULT EXCEEDS THE RANGE +-- OF THE BASE TYPE. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- LONG_INTEGER. + +-- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_LONG" MUST BE REJECTED. + + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- HISTORY: +-- HTG 10/06/86 CREATED ORIGINAL TEST. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; +PROCEDURE C45613C IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + RETURN LONG_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + +BEGIN + TEST ("C45613C","CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED BY ""**"" FOR LONG_INTEGER WHEN " & + "THE RESULT EXCEEDS THE RANGE OF THE BASE TYPE"); + + DECLARE + INT : LONG_INTEGER; + BEGIN + INT := IDENT(LONG_INTEGER'LAST ** IDENT_INT(2)); + FAILED ("NO EXCEPTION FOR SECOND POWER OF " & + "LONG_INTEGER'LAST"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "SECOND POWER OF " & + "LONG_INTEGER'LAST"); + END; + + DECLARE + INT : LONG_INTEGER; + BEGIN + INT := IDENT(LONG_INTEGER'FIRST ** IDENT_INT(3)); + FAILED ("NO EXCEPTION FOR THIRD POWER OF " & + "LONG_INTEGER'FIRST"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "THIRD POWER OF " & + "LONG_INTEGER'FIRST"); + + END; + + RESULT; + +END C45613C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45614a.ada b/gcc/testsuite/ada/acats/tests/c4/c45614a.ada new file mode 100644 index 000000000..9a0d835bd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45614a.ada @@ -0,0 +1,99 @@ +-- C45614A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE EXPONENT VALUE IN +-- AN INTEGER EXPONENTIATION IS NEGATIVE. +-- CHECK BOTH STATIC AND NONSTATIC EXPONENT VALUES. + +-- AH 9/29/86 +-- EDS 7/15/98 AVOID OPTIMIZATION + +WITH REPORT; USE REPORT; +PROCEDURE C45614A IS + INT : INTEGER :=1; + RES : INTEGER :=0; +BEGIN + TEST ("C45614A", "CONSTRAINT_ERROR IS RAISED FOR INTEGERS " & + "HAVING A NEGATIVE EXPONENT"); + + DECLARE + E1 : CONSTANT INTEGER := -5; + BEGIN + RES := INT ** E1; + FAILED ("CONSTRAINT_ERROR NOT RAISED - E1A " & + INTEGER'IMAGE(RES)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("CONSTRAINT_ERROR NOT RAISED - E1B"); + END; + + DECLARE + E2 : INTEGER := 5; + BEGIN + RES := INT ** (-E2); + FAILED ("CONSTRAINT_ERROR NOT RAISED - E2A " & + INTEGER'IMAGE(RES)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("CONSTRAINT_ERROR NOT RAISED - E2B"); + END; + + DECLARE + E3 : INTEGER; + BEGIN + E3 := IDENT_INT(-5); + RES := INT ** E3; + FAILED ("CONSTRAINT_ERROR NOT RAISED - E3A " & + INTEGER'IMAGE(RES)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("CONSTRAINT_ERROR NOT RAISED - E3B"); + END; + + DECLARE + BEGIN + RES := INT ** IDENT_INT(-5); + FAILED ("CONSTRAINT_ERROR NOT RAISED - E4A " & + INTEGER'IMAGE(RES)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("CONSTRAINT_ERROR NOT RAISED - E4B"); + END; + + RES := IDENT_INT(2); + RES := IDENT_INT(RES); + RESULT; +END C45614A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45614b.dep b/gcc/testsuite/ada/acats/tests/c4/c45614b.dep new file mode 100644 index 000000000..c96ab3330 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45614b.dep @@ -0,0 +1,128 @@ +-- C45614B.DEP + +-- 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 CONSTRAINT_ERROR IS RAISED BY PREDEFINED SHORT_INTEGER +-- "**" IF THE SECOND OPERAND HAS A NEGATIVE VALUE. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- SHORT_INTEGER. + +-- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_SHORT" MUST BE REJECTED. + +-- HISTORY: +-- HTG 10/07/86 CREATED ORIGINAL TEST. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + +WITH REPORT; USE REPORT; +PROCEDURE C45614B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + +BEGIN + + TEST ("C45614B", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "PREDEFINED SHORT_INTEGER ""**"" IF THE " & + "SECOND OPERAND HAS A NEGATIVE VALUE"); + + DECLARE + A : INTEGER := -2; + B : SHORT_INTEGER := 3; + INT : SHORT_INTEGER := 0; + BEGIN + INT := IDENT(B ** IDENT_INT(A)); + FAILED ("NO EXCEPTION FOR '3**(-2)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '3**(-2)'"); + END; + + DECLARE + A : INTEGER := -3; + B : SHORT_INTEGER := -5; + INT : SHORT_INTEGER := 0; + BEGIN + INT := IDENT(B ** IDENT_INT(A)); + FAILED ("NO EXCEPTION FOR '(-5)**(-3)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '(-5)**(-3)'"); + END; + + DECLARE + B : SHORT_INTEGER := 0; + INT : SHORT_INTEGER := 0; + BEGIN + INT := IDENT(B ** IDENT_INT(-3)); + FAILED ("NO EXCEPTION FOR '0**(-3)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '0**(-3)'"); + END; + + DECLARE + INT : SHORT_INTEGER := 0; + BEGIN + INT := IDENT(-10 ** IDENT_INT(-2)); + FAILED ("NO EXCEPTION FOR '(-10)**(-2)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '(-10)**(-2)'"); + END; + + DECLARE + INT : SHORT_INTEGER := 0; + BEGIN + INT := IDENT(6 ** IDENT_INT(-4)); + FAILED ("NO EXCEPTION FOR '6**(-4)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '6**(-4)'"); + END; + + RESULT; + +END C45614B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45614c.dep b/gcc/testsuite/ada/acats/tests/c4/c45614c.dep new file mode 100644 index 000000000..0a60a13b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45614c.dep @@ -0,0 +1,125 @@ +-- C45614C.DEP + +-- 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 CONSTRAINT_ERROR IS RAISED BY PREDEFINED +-- LONG_INTEGER "**" IF THE SECOND OPERAND HAS A NEGATIVE +-- VALUE. + +-- APPLICABILITY CRITERIA: +-- IN ORDER FOR THIS TEST TO BE NOT-APPLICABLE THE COMPILER +-- MUST REJECT THE USE OF "LONG_INTEGER" AS AN UNDECLARED +-- IDENTIFIER. + +-- HISTORY: +-- HT 10/07/86 CREATED ORIGINAL TEST. +-- JET 08/06/87 REMOVED BUG FROM FUNCTION IDENT (X). + +WITH REPORT; USE REPORT; +PROCEDURE C45614C IS + + FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + RETURN LONG_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + +BEGIN + + TEST ("C45614C", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "PREDEFINED LONG_INTEGER ""**"" IF THE SECOND " & + "OPERAND HAS A NEGATIVE VALUE"); + + DECLARE + A : INTEGER := -2; + B : LONG_INTEGER := 3; + INT : LONG_INTEGER := 0; + BEGIN + INT := IDENT(B ** IDENT_INT(A)); + FAILED ("NO EXCEPTION FOR '3**(-2)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '3**(-2)'"); + END; + + DECLARE + A : INTEGER := -3; + B : LONG_INTEGER := -5; + INT : LONG_INTEGER := 0; + BEGIN + INT := IDENT(B ** IDENT_INT(A)); + FAILED ("NO EXCEPTION FOR '(-5)**(-3)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '(-5)**(-3)'"); + END; + + DECLARE + B : LONG_INTEGER := 0; + INT : LONG_INTEGER := 0; + BEGIN + INT := IDENT(B ** IDENT_INT(-3)); + FAILED ("NO EXCEPTION FOR '0**(-3)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '0**(-3)'"); + END; + + DECLARE + INT : LONG_INTEGER := 0; + BEGIN + INT := IDENT(-10 ** IDENT_INT(-2)); + FAILED ("NO EXCEPTION FOR '(-10)**(-2)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '(-10)**(-2)'"); + END; + + DECLARE + INT : LONG_INTEGER := 0; + BEGIN + INT := IDENT(6 ** IDENT_INT(-4)); + FAILED ("NO EXCEPTION FOR '6**(-4)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '6**(-4)'"); + END; + + RESULT; + +END C45614C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45622a.ada b/gcc/testsuite/ada/acats/tests/c4/c45622a.ada new file mode 100644 index 000000000..42f02045f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45622a.ada @@ -0,0 +1,83 @@ +-- C45622A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR EXPONENTIATION OF FLOATING POINT TYPES, CHECK THAT +-- CONSTRAINT_ERROR IS RAISED IF +-- MACHINE_OVERFLOWS IS TRUE AND THE RESULT IS OUTSIDE THE RANGE OF +-- THE BASE TYPE. THIS TESTS DIGITS 5. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- HISTORY: +-- BCB 02/09/88 CREATED ORIGINAL TEST. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; + +PROCEDURE C45622A IS + + TYPE FLT IS DIGITS 5; + + F : FLT; + + FUNCTION EQUAL_FLT (ONE, TWO : FLT) RETURN BOOLEAN IS + BEGIN + RETURN ONE = TWO * FLT (IDENT_INT(1)); + END EQUAL_FLT; + +BEGIN + TEST ("C45622A", "FOR EXPONENTIATION OF FLOATING POINT TYPES, " & + "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED IF MACHINE_OVERFLOWS IS TRUE AND " & + "THE RESULT IS OUTSIDE THE RANGE OF THE BASE " & + "TYPE. THIS TESTS DIGITS 5"); + + IF FLT'MACHINE_OVERFLOWS THEN + BEGIN + F := (FLT'BASE'LAST)**IDENT_INT (2); + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED FOR " & + "EXPONENTIATION"); + + IF NOT EQUAL_FLT(F,F) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR WAS RAISED FOR " & + "EXPONENTIATION"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED FOR EXPONENTIATION"); + END; + ELSE + NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " & + "MACHINE_OVERFLOWS BEING FALSE"); + END IF; + + RESULT; +END C45622A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45624a.ada b/gcc/testsuite/ada/acats/tests/c4/c45624a.ada new file mode 100644 index 000000000..32ba4c07a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45624a.ada @@ -0,0 +1,86 @@ +-- C45624A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR FLOATING POINT TYPES, CHECK THAT CONSTRAINT_ERROR +-- IS RAISED IF THE RESULT OF A FLOATING POINT +-- EXPONENTIATION IS OUTSIDE THE RANGE OF THE BASE TYPE AND +-- MACHINE_OVERFLOWS IS FALSE. THIS TESTS DIGITS 5. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- HISTORY: +-- BCB 02/09/88 CREATED ORIGINAL TEST. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; + +PROCEDURE C45624A IS + + TYPE FLT IS DIGITS 5; + + F : FLT; + + FUNCTION EQUAL_FLT (ONE, TWO : FLT) RETURN BOOLEAN IS + BEGIN + IF EQUAL(3,3) THEN + RETURN ONE = TWO; + ELSE + RETURN ONE /= TWO; + END IF; + END EQUAL_FLT; + +BEGIN + TEST ("C45624A", "FOR FLOATING POINT TYPES, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED " & + "IF MACHINE_OVERFLOWS IS FALSE. THIS TESTS " & + "DIGITS 5"); + + IF FLT'MACHINE_OVERFLOWS THEN + NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " & + "MACHINE_OVERFLOWS BEING TRUE"); + ELSE + BEGIN + F := FLT'BASE'FIRST**IDENT_INT (2); + COMMENT ("CONSTRAINT_ERROR WAS NOT RAISED WHEN " & + "MACHINE_OVERFLOWS WAS FALSE"); + + IF EQUAL_FLT(F,F**IDENT_INT(1)) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR WAS RAISED WHEN " & + "MACHINE_OVERFLOWS WAS FALSE"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED"); + END; + END IF; + + RESULT; +END C45624A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45624b.ada b/gcc/testsuite/ada/acats/tests/c4/c45624b.ada new file mode 100644 index 000000000..c7bd592d6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45624b.ada @@ -0,0 +1,81 @@ +-- C45624B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR FLOATING POINT TYPES, CHECK THAT +-- CONSTRAINT_ERROR IS RAISED IF THE RESULT OF A FLOATING POINT +-- EXPONENTIATION IS OUTSIDE THE RANGE OF THE BASE TYPE AND +-- MACHINE_OVERFLOWS IS FALSE. THIS TESTS DIGITS 6. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- HISTORY: +-- BCB 07/14/88 CREATED ORIGINAL TEST. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; + +PROCEDURE C45624B IS + + TYPE FLT IS DIGITS 6; + + F : FLT; + + FUNCTION EQUAL_FLT (ONE, TWO : FLT) RETURN BOOLEAN IS + BEGIN + RETURN ONE = TWO * FLT (IDENT_INT(1)); + END EQUAL_FLT; + +BEGIN + TEST ("C45624B", "FOR FLOATING POINT TYPES, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED " & + "IF MACHINE_OVERFLOWS IS FALSE. THIS TESTS " & + "DIGITS 6"); + + IF FLT'MACHINE_OVERFLOWS THEN + NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " & + "MACHINE_OVERFLOWS BEING TRUE"); + ELSE + BEGIN + F := FLT'BASE'LAST**IDENT_INT (2); + COMMENT ("CONSTRAINT_ERROR WAS NOT RAISED WHEN " & + "MACHINE_OVERFLOWS WAS FALSE"); + IF NOT EQUAL_FLT(F,F**IDENT_INT(1)) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR WAS RAISED WHEN " & + "MACHINE_OVERFLOWS WAS FALSE"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED"); + END; + END IF; + + RESULT; +END C45624B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45631a.ada b/gcc/testsuite/ada/acats/tests/c4/c45631a.ada new file mode 100644 index 000000000..43f794abc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45631a.ada @@ -0,0 +1,98 @@ +-- C45631A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR TYPE INTEGER 'ABS A' EQUALS A IF A IS POSITIVE AND +-- EQUALS -A IF A IS NEGATIVE. + +-- RJW 2/10/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C45631A IS + +BEGIN + + TEST ( "C45631A", "CHECK THAT FOR TYPE INTEGER 'ABS A' " & + "EQUALS A IF A IS POSITIVE AND EQUALS -A IF " & + "A IS NEGATIVE" ); + + DECLARE + + P : INTEGER := IDENT_INT (1); + N : INTEGER := IDENT_INT (-1); + Z : INTEGER := IDENT_INT (0); + BEGIN + + IF ABS P = P THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR P - 1" ); + END IF; + + IF ABS N = -N THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR N - 1" ); + END IF; + + IF ABS Z = Z THEN + NULL; + ELSE + FAILED ( "'ABS TEST FOR Z - 1" ); + END IF; + + IF ABS (Z) = -Z THEN + NULL; + ELSE + FAILED ( "'ABS TEST FOR Z - 2"); + END IF; + + IF "ABS" (RIGHT => P) = P THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR P - 2" ); + END IF; + + IF "ABS" (N) = -N THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR N - 2 " ); + END IF; + + IF "ABS" (Z) = Z THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR Z - 3" ); + END IF; + + IF ABS (IDENT_INT (-INTEGER'LAST)) = INTEGER'LAST THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR -INTEGER'LAST" ); + END IF; + END; + + RESULT; + +END C45631A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45631b.dep b/gcc/testsuite/ada/acats/tests/c4/c45631b.dep new file mode 100644 index 000000000..750ea210d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45631b.dep @@ -0,0 +1,116 @@ +-- C45631B.DEP + +-- 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 TYPE SHORT_INTEGER 'ABS A' EQUALS A IF A IS +-- POSITIVE AND EQUALS -A IF A IS NEGATIVE. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- SHORT_INTEGER. + +-- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_SHORT" MUST BE REJECTED. + +-- HISTORY: +-- RJW 02/26/86 CREATED ORIGINAL TEST. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + +WITH REPORT; USE REPORT; + +PROCEDURE C45631B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + +BEGIN + + TEST ( "C45631B", "CHECK THAT FOR TYPE SHORT_INTEGER 'ABS A' " & + "EQUALS A IF A IS POSITIVE AND EQUALS -A IF " & + "A IS NEGATIVE" ); + + DECLARE + + P : SHORT_INTEGER := IDENT (1); + N : SHORT_INTEGER := IDENT (-1); + Z : SHORT_INTEGER := IDENT (0); + BEGIN + + IF ABS P = P THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR P - 1" ); + END IF; + + IF ABS N = -N THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR N - 1" ); + END IF; + + IF ABS Z = Z THEN + NULL; + ELSE + FAILED ( "'ABS TEST FOR Z - 1" ); + END IF; + + IF ABS (Z) = -Z THEN + NULL; + ELSE + FAILED ( "'ABS TEST FOR Z - 2"); + END IF; + + IF "ABS" (RIGHT => P) = P THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR P - 2" ); + END IF; + + IF "ABS" (N) = -N THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR N - 2 " ); + END IF; + + IF "ABS" (Z) = Z THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR Z - 3" ); + END IF; + + IF ABS (IDENT (-SHORT_INTEGER'LAST)) = SHORT_INTEGER'LAST + THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR -SHORT_INTEGER'LAST" ); + END IF; + END; + + RESULT; + +END C45631B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45631c.dep b/gcc/testsuite/ada/acats/tests/c4/c45631c.dep new file mode 100644 index 000000000..2d47637ab --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45631c.dep @@ -0,0 +1,122 @@ +-- C45631C.DEP + +-- 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 TYPE LONG_INTEGER 'ABS A' EQUALS A IF A IS +-- POSITIVE AND EQUALS -A IF A IS NEGATIVE. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT +-- LONG_INTEGER. + +-- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF +-- "CHECK_LONG" MUST BE REJECTED. + +-- HISTORY: +-- RJW 02/26/86 CREATED ORIGINAL TEST. +-- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + +WITH REPORT; USE REPORT; + +PROCEDURE C45631C IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + IF X >= LONG_INTEGER (INTEGER'FIRST) AND + X <= LONG_INTEGER (INTEGER'LAST) THEN + RETURN LONG_INTEGER (IDENT_INT (INTEGER (X))); + ELSIF EQUAL (3, 3) THEN + RETURN X; + END IF; + RETURN 0; + END IDENT; + +BEGIN + + TEST ( "C45631C", "CHECK THAT FOR TYPE LONG_INTEGER 'ABS A' " & + "EQUALS A IF A IS POSITIVE AND EQUALS -A IF " & + "A IS NEGATIVE" ); + + DECLARE + + P : LONG_INTEGER := IDENT (1); + N : LONG_INTEGER := IDENT (-1); + Z : LONG_INTEGER := IDENT (0); + BEGIN + + IF ABS P = P THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR P - 1" ); + END IF; + + IF ABS N = -N THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR N - 1" ); + END IF; + + IF ABS Z = Z THEN + NULL; + ELSE + FAILED ( "'ABS TEST FOR Z - 1" ); + END IF; + + IF ABS (Z) = -Z THEN + NULL; + ELSE + FAILED ( "'ABS TEST FOR Z - 2"); + END IF; + + IF "ABS" (RIGHT => P) = P THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR P - 2" ); + END IF; + + IF "ABS" (N) = -N THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR N - 2 " ); + END IF; + + IF "ABS" (Z) = Z THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR Z - 3" ); + END IF; + + IF ABS (IDENT (-LONG_INTEGER'LAST)) = LONG_INTEGER'LAST + THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR -LONG_INTEGER'LAST" ); + END IF; + END; + + RESULT; + +END C45631C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45632a.ada b/gcc/testsuite/ada/acats/tests/c4/c45632a.ada new file mode 100644 index 000000000..399188eb0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45632a.ada @@ -0,0 +1,76 @@ +-- C45632A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT FOR PREDEFINED TYPE INTEGER, CONSTRAINT_ERROR +-- IS RAISED FOR ABS (INTEGER'FIRST) IF +-- -INTEGER'LAST > INTEGER'FIRST. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- HISTORY: +-- RJW 02/10/86 CREATED ORIGINAL TEST. +-- JET 12/30/87 UPDATED HEADER FORMAT AND ADDED CODE TO +-- PREVENT OPTIMIZATION. +-- MRM 03/30/93 REMOVED NUMERIC ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; + +PROCEDURE C45632A IS + + I : INTEGER := IDENT_INT (INTEGER'FIRST); + +BEGIN + + TEST ( "C45632A", "CHECK THAT FOR PREDEFINED TYPE INTEGER " & + "CONSTRAINT_ERROR IS RAISED " & + "FOR ABS (INTEGER'FIRST) IF -INTEGER'LAST > " & + "INTEGER'FIRST" ); + + BEGIN + IF - INTEGER'LAST > INTEGER'FIRST THEN + BEGIN + IF EQUAL (ABS I, I) THEN + NULL; + ELSE + FAILED ( "WRONG RESULT FOR ABS" ); + END IF; + FAILED ( "EXCEPTION NOT RAISED" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED" ); + END; + ELSE + COMMENT ( "-INTEGER'LAST <= INTEGER'FIRST" ); + END IF; + END; + + RESULT; + +END C45632A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45632b.dep b/gcc/testsuite/ada/acats/tests/c4/c45632b.dep new file mode 100644 index 000000000..fdf33713a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45632b.dep @@ -0,0 +1,94 @@ +-- C45632B.DEP + +-- 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 PREDEFINED TYPE SHORT_INTEGER, +-- CONSTRAINT_ERROR IS RAISED FOR ABS (SHORT_INTEGER'FIRST) +-- IF -SHORT_INTEGER'LAST > SHORT_INTEGER'FIRST. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT +-- THE PREDEFINED TYPE "SHORT_INTEGER". + +-- IF SUCH A TYPE IS NOT SUPPORTED, THEN THE DECLARATION OF THE +-- VARIABLE "TEST_VAR" MUST BE REJECTED. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- HISTORY: +-- RJW 02/20/86 CREATED ORIGINAL TEST. +-- JET 12/30/87 UPDATED HEADER FORMAT, ADDED CODE TO DEFEAT +-- OPTIMIZATION. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; + +PROCEDURE C45632B IS + + TEST_VAR : SHORT_INTEGER; -- N/A => ERROR. + I : SHORT_INTEGER; + + FUNCTION IDENT_SHORT (A : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + IF EQUAL (3,3) THEN + RETURN A; + ELSE + RETURN 0; + END IF; + END IDENT_SHORT; + +BEGIN + + TEST ( "C45632B", "CHECK THAT FOR PREDEFINED TYPE " & + "SHORT_INTEGER CONSTRAINT_ERROR IS RAISED FOR " & + "ABS (SHORT_INTEGER'FIRST) IF " & + "-SHORT_INTEGER'LAST > SHORT_INTEGER'FIRST"); + + BEGIN + I := IDENT_SHORT (SHORT_INTEGER'FIRST); + + IF -SHORT_INTEGER'LAST > SHORT_INTEGER'FIRST THEN + BEGIN + IF IDENT_SHORT (ABS I) = IDENT_SHORT (I) THEN + FAILED ("NO EXCEPTION -- EQUALITY TRUE"); + ELSE + FAILED ("NO EXCEPTION -- EQUALITY FALSE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED" ); + END; + ELSE + COMMENT ( "-SHORT_INTEGER'LAST <= SHORT_INTEGER'FIRST"); + END IF; + END; + + RESULT; + +END C45632B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45632c.dep b/gcc/testsuite/ada/acats/tests/c4/c45632c.dep new file mode 100644 index 000000000..72564bf5b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45632c.dep @@ -0,0 +1,94 @@ +-- C45632C.DEP + +-- 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 PREDEFINED TYPE LONG_INTEGER, +-- CONSTRAINT_ERROR IS RAISED FOR ABS (LONG_INTEGER'FIRST) +-- IF -LONG_INTEGER'LAST > LONG_INTEGER'FIRST. + +-- APPLICABILITY CRITERIA: +-- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT +-- THE USE OF "LONG_INTEGER" AS A PREDEFINED DATA TYPE. + +-- IF SUCH A TYPE IS NOT SUPPORTED, THEN THE DECLARATION OF THE +-- VARIABLE "TEST_VAR" MUST BE REJECTED. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- HISTORY: +-- RJW 02/20/86 CREATED ORIGINAL TEST. +-- JET 12/30/87 UPDATED HEADER FORMAT, ADDED CODE TO DEFEAT +-- OPTIMIZATION. +-- MRM 03/30/93 REMOVED NUMERIC ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; + +PROCEDURE C45632C IS + + TEST_VAR : LONG_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT_LONG (A : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + IF EQUAL (3,3) THEN + RETURN A; + ELSE + RETURN 0; + END IF; + END IDENT_LONG; + +BEGIN + + TEST ( "C45632C", "CHECK THAT FOR PREDEFINED TYPE " & + "LONG_INTEGER CONSTRAINT_ERROR IS RAISED FOR " & + "ABS (LONG_INTEGER'FIRST) IF " & + "-LONG_INTEGER'LAST > LONG_INTEGER'FIRST" ); + + BEGIN + IF - LONG_INTEGER'LAST > LONG_INTEGER'FIRST THEN + DECLARE + I : LONG_INTEGER := IDENT_LONG(LONG_INTEGER'FIRST); + BEGIN + IF IDENT_LONG(ABS I) = IDENT_LONG(I) THEN + FAILED ("NO EXCEPTION -- EQUALITY TRUE"); + ELSE + FAILED ("NO EXCEPTION -- EQUALITY FALSE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED" ); + END; + ELSE + COMMENT ( "-LONG_INTEGER'LAST <= " & + "LONG_INTEGER'FIRST" ); + END IF; + END; + + RESULT; + +END C45632C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45651a.ada b/gcc/testsuite/ada/acats/tests/c4/c45651a.ada new file mode 100644 index 000000000..c568b843b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45651a.ada @@ -0,0 +1,246 @@ +-- C45651A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR FIXED POINT TYPES, CHECK: +-- (A) FOR MODEL NUMBERS A >= 0.0, THAT ABS A = A. +-- (B) FOR MODEL NUMBERS A <= 0.0. THAT ABS A = -A. +-- (C) FOR NON-MODEL NUMBERS A > 0.0, THAT ABS A VALUES ARE +-- WITHIN THE APPROPRIATE MODEL INTERVAL. +-- (D) FOR NON-MODEL NUMBERS A < 0.0, THAT ABS A VALUES ARE +-- WITHIN THE APPROPRIATE MODEL INTERVAL. + +-- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF +-- DURATION'BASE. + +-- HISTORY: +-- WRG 9/11/86 +-- PWB 3/31/88 CHANGED RANGE FOR MEMBERSHIP TEST INVOLVING +-- ABS (DECIMAL_M4'FIRST + DECIMAL_M4'SMALL / 2). +-- RJW 8/21/89 REMOVED CHECKS INVOLVING HARD-CODED FIXED-POINT +-- UPPER BOUNDS WHICH WERE INCORRECT FOR SOME +-- IMPLEMENTATIONS. REVISED HEADER. +-- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. +-- KAS 11/14/95 REMOVED CASES THAT DEPEND ON SPECIFIC VALUE FOR 'SMALL +-- TMB 11/19/94 REMOVED CASES RELATING TO 3.5.9(8) RULES - SMALL +-- MAY BE LESS THAN OR EQUAL TO DELTA FOR FIXED POINT. + +WITH REPORT; USE REPORT; +PROCEDURE C45651A IS + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + +BEGIN + + TEST ("C45651A", "CHECK THAT, FOR FIXED POINT TYPES, THE ABS " & + "OPERATOR PRODUCES CORRECT RESULTS - BASIC " & + "TYPES"); + + ------------------------------------------------------------------- + +A: DECLARE + TYPE LIKE_DURATION_M23 IS DELTA 0.020 + RANGE -86_400.0 .. 86_400.0; + + NON_MODEL_CONST : CONSTANT := 2.0 / 3; + NON_MODEL_VAR : LIKE_DURATION_M23 := 0.0; + + SMALL, MAX, MIN, ZERO : LIKE_DURATION_M23 := 0.5; + X : LIKE_DURATION_M23 := 1.0; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + SMALL := LIKE_DURATION_M23'SMALL; + MAX := LIKE_DURATION_M23'LAST; + MIN := LIKE_DURATION_M23'FIRST; + ZERO := 0.0; + NON_MODEL_VAR := NON_MODEL_CONST; + END IF; + + -- (A) + IF EQUAL (3, 3) THEN + X := SMALL; + END IF; + IF ABS X /= SMALL OR X /= ABS LIKE_DURATION_M23'SMALL THEN + FAILED ("ABS (1.0 / 64) /= (1.0 / 64)"); + END IF; + IF EQUAL (3, 3) THEN + X := MAX; + END IF; + IF ABS X /= MAX OR X /= ABS LIKE_DURATION_M23'LAST THEN + FAILED ("ABS 86_400.0 /= 86_400.0"); + END IF; + + -- (B) + IF EQUAL (3, 3) THEN + X := -SMALL; + END IF; + IF ABS X /= SMALL OR + ABS (-LIKE_DURATION_M23'SMALL) /= SMALL THEN + FAILED ("ABS -(1.0 / 64) /= (1.0 / 64)"); + END IF; + IF EQUAL (3, 3) THEN + X := MIN; + END IF; + IF ABS X /= MAX OR ABS LIKE_DURATION_M23'FIRST /= MAX THEN + FAILED ("ABS -86_400.0 /= 86_400.0"); + END IF; + + -- (A) AND (B) + IF EQUAL (3, 3) THEN + X := 0.0; + END IF; + IF "ABS" (RIGHT => X) /= ZERO OR X /= ABS 0.0 THEN + FAILED ("ABS 0.0 /= 0.0 -- (LIKE_DURATION_M23)"); + END IF; + + -- CHECK THAT VALUE OF NON_MODEL_VAR IS IN THE RANGE + -- 42 * 'SMALL .. 43 * 'SMALL: + IF NON_MODEL_VAR NOT IN 0.65625 .. 0.671875 THEN + FAILED ("VALUE OF NON_MODEL_VAR NOT IN CORRECT RANGE " & + "- A"); + END IF; + + -- (C) + IF ABS NON_MODEL_VAR NOT IN 0.65625 .. 0.671875 OR + ABS LIKE_DURATION_M23'(NON_MODEL_CONST) NOT IN + 0.65625 .. 0.671875 THEN + FAILED ("ABS (2.0 / 3) NOT IN CORRECT RANGE - A"); + END IF; + IF EQUAL (3, 3) THEN + X := 86_399.992_187_5; -- LIKE_DURATION_M23'LAST - + -- 1.0 / 128. + END IF; + IF ABS X NOT IN 86_399.984_375 .. 86_400.0 OR + ABS (LIKE_DURATION_M23'LAST - LIKE_DURATION_M23'SMALL / 2) + NOT IN 86_399.984_375 .. 86_400.0 THEN + FAILED ("ABS (LIKE_DURATION_M23'LAST - " & + "LIKE_DURATION_M23'SMALL / 2) NOT IN CORRECT " & + "RANGE"); + END IF; + + -- (D) + IF EQUAL (3, 3) THEN + X := -NON_MODEL_CONST; + END IF; + IF ABS X NOT IN 0.65625 .. 0.671875 OR + ABS (-LIKE_DURATION_M23'(NON_MODEL_CONST)) NOT IN + 0.65625 .. 0.671875 THEN + FAILED ("ABS (-2.0 / 3) NOT IN CORRECT RANGE - A"); + END IF; + IF EQUAL (3, 3) THEN + X := -86_399.992_187_5; -- LIKE_DURATION_M23'FIRST + + -- 1.0 / 128. + END IF; + IF ABS X NOT IN 86_399.984_375 .. 86_400.0 OR + ABS (LIKE_DURATION_M23'FIRST + LIKE_DURATION_M23'SMALL / 2) + NOT IN 86_399.984_375 .. 86_400.0 THEN + FAILED ("ABS (LIKE_DURATION_M23'FIRST +" & + "LIKE_DURATION_M23'SMALL / 2) NOT IN CORRECT " & + "RANGE"); + END IF; + END A; + + ------------------------------------------------------------------- + +B: DECLARE + TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0; + + NON_MODEL_CONST : CONSTANT := 2.0 / 3; + NON_MODEL_VAR : DECIMAL_M4 := 0.0; + + SMALL, MAX, MIN, ZERO : DECIMAL_M4 := 128.0; + X : DECIMAL_M4 := 0.0; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + SMALL := DECIMAL_M4'SMALL; + ZERO := 0.0; + NON_MODEL_VAR := NON_MODEL_CONST; + END IF; + + -- (A) + IF EQUAL (3, 3) THEN + X := SMALL; + END IF; + IF ABS X /= SMALL OR X /= ABS DECIMAL_M4'SMALL THEN + FAILED ("ABS 64.0 /= 64.0"); + END IF; + + -- (B) + IF EQUAL (3, 3) THEN + X := -SMALL; + END IF; + IF ABS X /= SMALL OR ABS (-DECIMAL_M4'SMALL) /= SMALL THEN + FAILED ("ABS -64.0 /= 64.0"); + END IF; + + -- (A) AND (B) + IF EQUAL (3, 3) THEN + X := 0.0; + END IF; + IF ABS X /= ZERO OR X /= ABS 0.0 THEN + FAILED ("ABS 0.0 /= 0.0 -- (DECIMAL_M4)"); + END IF; + + -- CHECK THE VALUE OF NON_MODEL_VAR: + IF NON_MODEL_VAR NOT IN 0.0 .. 64.0 THEN + FAILED ("VALUE OF NON_MODEL_VAR NOT IN CORRECT RANGE " & + "- B"); + END IF; + + -- (C) + IF ABS NON_MODEL_VAR NOT IN 0.0 .. 64.0 OR + ABS DECIMAL_M4'(NON_MODEL_CONST) NOT IN 0.0 .. 64.0 THEN + FAILED ("ABS (2.0 / 3) NOT IN CORRECT RANGE - B"); + END IF; + IF EQUAL (3, 3) THEN + X := 37.0; -- INTERVAL IS 0.0 .. 64.0. + END IF; + IF EQUAL (3, 3) THEN + X := 928.0; + END IF; + + -- (D) + IF EQUAL (3, 3) THEN + X := -NON_MODEL_CONST; + END IF; + IF ABS X NOT IN 0.0 .. 64.0 OR + ABS (-DECIMAL_M4'(NON_MODEL_CONST)) NOT IN 0.0 .. 64.0 THEN + FAILED ("ABS -(2.0 / 3) NOT IN CORRECT RANGE - B"); + END IF; + IF EQUAL (3, 3) THEN + X := -37.0; -- INTERVAL IS -SMALL .. 0.0. + END IF; + IF EQUAL (3, 3) THEN + X := -928.0; + END IF; + END B; + + ------------------------------------------------------------------- + + RESULT; + +END C45651A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45662a.ada b/gcc/testsuite/ada/acats/tests/c4/c45662a.ada new file mode 100644 index 000000000..bf23598e3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45662a.ada @@ -0,0 +1,105 @@ +-- C45662A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THE TRUTH TABLE FOR 'NOT' . + +-- THE COMBINATIONS OF 'NOT' WITH 'AND' , 'OR' , 'XOR' ARE TESTED +-- IN C45101(A,G). + + +-- RM 28 OCTOBER 1980 +-- TBN 10/21/85 RENAMED FROM C45401A.ADA. + + +WITH REPORT ; +PROCEDURE C45662A IS + + USE REPORT; + + TVAR , FVAR , CVAR : BOOLEAN := FALSE ; -- INITIAL VALUE IRRELEVANT + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + +BEGIN + + TEST( "C45662A" , "CHECK THE TRUTH TABLE FOR 'NOT'" ) ; + + FOR A IN BOOLEAN LOOP + + CVAR := NOT A ; + + IF NOT A THEN + IF A THEN BUMP ; + END IF ; + END IF; + + IF CVAR THEN + IF A THEN BUMP ; + END IF ; + END IF; + + IF NOT( NOT( NOT( NOT( CVAR )))) + THEN + IF A THEN BUMP ; + END IF ; + END IF; + + END LOOP ; + + FOR I IN 1..2 LOOP + + CVAR := NOT ( I > 1 ) ; + + IF NOT ( I > 1 ) THEN + IF I>1 THEN BUMP ; + END IF ; + END IF; + + IF CVAR THEN + IF I>1 THEN BUMP ; + END IF ; + END IF; + + END LOOP ; + + IF NOT TRUE THEN BUMP ; END IF ; + IF NOT FALSE THEN NULL ; ELSE BUMP ; END IF ; + + TVAR := IDENT_BOOL( TRUE ); + FVAR := IDENT_BOOL( FALSE ); + + IF NOT TVAR THEN BUMP ; END IF ; + IF NOT FVAR THEN NULL ; ELSE BUMP ; END IF ; + + + IF ERROR_COUNT /= 0 THEN FAILED( "'NOT' TRUTH TABLE" ); + END IF ; + + RESULT; + +END C45662A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45662b.ada b/gcc/testsuite/ada/acats/tests/c4/c45662b.ada new file mode 100644 index 000000000..7feb6a655 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45662b.ada @@ -0,0 +1,120 @@ +-- C45662B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THE TRUTH TABLE FOR 'NOT' ON DERIVED-BOOLEAN-TYPE OPERANDS. + +-- THE COMBINATIONS OF 'NOT' WITH 'AND' , 'OR' , 'XOR' ARE TESTED +-- IN C45101K. + + +-- RM 28 OCTOBER 1980 +-- TBN 10/21/85 RENAMED FROM C45401B-AB.ADA. REMOVED DUPLICATED +-- CODE NEAR END. + +WITH REPORT; USE REPORT; +PROCEDURE C45662B IS + + TYPE NB IS NEW BOOLEAN ; + + TVAR , FVAR , CVAR : NB := NB'(FALSE) ; -- INITIAL VALUE IRRELEVANT + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + FUNCTION IDENT_NEW_BOOL( THE_ARGUMENT : NB ) RETURN NB IS + BEGIN + IF EQUAL(2,2) THEN RETURN THE_ARGUMENT; + ELSE RETURN NB'(FALSE) ; + END IF; + END ; + + +BEGIN + + TEST( "C45662B" , "CHECK THE TRUTH TABLE FOR 'NOT'" & + " ON DERIVED-BOOLEAN-TYPE OPERANDS" ) ; + + FOR A IN NB LOOP + + CVAR := NOT A ; + + IF BOOLEAN( NOT A ) THEN + IF BOOLEAN( A ) THEN BUMP ; + END IF ; + END IF; + + IF BOOLEAN( CVAR ) THEN + IF BOOLEAN( A ) THEN BUMP ; + END IF ; + END IF; + + IF BOOLEAN( + + NOT( NOT( NOT( NOT( NOT( + NOT( NOT( NOT( NOT( NOT( + NOT( NOT( NOT( NOT( NOT( + NOT( NOT( NOT( NOT( NOT( CVAR ))))) ))))) ))))) ))))) + ) + THEN + IF BOOLEAN( A ) THEN BUMP ; + END IF ; + END IF; + + END LOOP ; + + FOR I IN 1..2 LOOP + + CVAR := NOT( NB( I > 1 ) ) ; + + IF BOOLEAN( NOT( NB( I > 1 ))) THEN + IF I>1 THEN BUMP ; + END IF ; + END IF; + + IF BOOLEAN( CVAR ) THEN + IF I>1 THEN BUMP ; + END IF ; + END IF; + + END LOOP ; + + IF BOOLEAN( NOT( NB'(TRUE ))) THEN BUMP ; END IF ; + IF BOOLEAN( NOT( NB'(FALSE))) THEN NULL ; ELSE BUMP ; END IF ; + + + TVAR := IDENT_NEW_BOOL( NB'(TRUE ) ); + FVAR := IDENT_NEW_BOOL( NB'(FALSE) ); + + IF BOOLEAN( NOT TVAR ) THEN BUMP ; END IF ; + IF BOOLEAN( NOT FVAR ) THEN NULL ; ELSE BUMP ; END IF ; + + IF ERROR_COUNT /= 0 THEN FAILED( "'NOT' TRUTH TABLE" ); + END IF ; + + RESULT; + +END C45662B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45672a.ada b/gcc/testsuite/ada/acats/tests/c4/c45672a.ada new file mode 100644 index 000000000..1e5405525 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45672a.ada @@ -0,0 +1,109 @@ +-- C45672A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT "NOT" YIELDS THE CORRECT RESULTS WHEN APPLIED TO +-- ONE-DIMENSIONAL BOOLEAN ARRAYS. + +-- JWC 11/15/85 + +WITH REPORT;USE REPORT; + +PROCEDURE C45672A IS +BEGIN + + TEST ("C45672A", "CHECK THE UNARY OPERATOR 'NOT' APPLIED TO " & + "ONE-DIMENSIONAL BOOLEAN ARRAYS"); + + DECLARE + + TYPE ARR1 IS ARRAY (INTEGER RANGE 1 .. 4) OF BOOLEAN; + TYPE ARR2 IS ARRAY (INTEGER RANGE 1 .. 40) OF BOOLEAN; + TYPE ARR3 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + TYPE ARR4 IS ARRAY (INTEGER RANGE 1 .. 4) OF BOOLEAN; + TYPE ARR5 IS ARRAY (INTEGER RANGE 1 .. 40) OF BOOLEAN; + + PRAGMA PACK (ARR4); + PRAGMA PACK (ARR5); + + A1 : ARR1 := ARR1'(1 | 3 => TRUE, OTHERS => FALSE); + A2 : ARR2 := ARR2'(1 | 14 .. 18 | 30 .. 33 | 35 .. 37 => TRUE, + OTHERS => FALSE); + A3 : ARR3(IDENT_INT(3) .. IDENT_INT(4)) := ARR3'(TRUE, FALSE); + A4 : ARR4 := ARR4'(1 | 3 => TRUE, OTHERS => FALSE); + A5 : ARR5 := ARR5'(1 | 14 .. 18 | 30 .. 33 | 35 .. 37 => TRUE, + OTHERS => FALSE); + A6 : ARR3 (IDENT_INT(9) .. IDENT_INT(7)); + + PROCEDURE P (A : ARR3; F : INTEGER; L : INTEGER) IS + BEGIN + IF A'FIRST /= F OR A'LAST /= L THEN + FAILED ("'NOT' YIELDED THE WRONG BOUNDS"); + END IF; + END P; + + BEGIN + + P (NOT A3, 3, 4); + P (NOT A6, 9, 7); + + IF NOT A1 /= ARR1'(1 | 3 => FALSE, OTHERS => TRUE) THEN + FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " & + "TO SMALL ARRAY"); + END IF; + + IF NOT A2 /= ARR2'(1 | 14 .. 18 | 30 .. 33 | 35 .. 37 + => FALSE, OTHERS => TRUE) THEN + FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " & + "TO LARGE ARRAY"); + END IF; + + IF NOT A4 /= ARR4'(1 | 3 => FALSE, OTHERS => TRUE) THEN + FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " & + "TO SMALL PACKED ARRAY"); + END IF; + + IF NOT A5 /= ARR5'(1 | 14 .. 18 | 30 .. 33 | 35 .. 37 + => FALSE, OTHERS => TRUE) THEN + FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " & + "TO LARGE PACKED ARRAY"); + END IF; + + IF "NOT" (RIGHT => A1) /= ARR1'(1 | 3 => FALSE, + OTHERS => TRUE) THEN + FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " & + "TO SMALL ARRAY USING NAMED NOTATION"); + END IF; + + IF "NOT" (RIGHT => A5) /= ARR5'(1 | 14 .. 18 | 30 .. 33 | + 35 .. 37 => FALSE, + OTHERS => TRUE) THEN + FAILED ("WRONG RESULT WHEN 'NOT' APPLIED TO LARGE " & + "PACKED ARRAY USING NAMED NOTATION"); + END IF; + + END; + + RESULT; + +END C45672A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460001.a b/gcc/testsuite/ada/acats/tests/c4/c460001.a new file mode 100644 index 000000000..907b8564f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460001.a @@ -0,0 +1,300 @@ +-- C460001.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 if the target type of a type conversion is a general +-- access type, Program_Error is raised if the accessibility level +-- of the operand type is deeper than that of the target type. +-- Check for the case where the operand is an access parameter. +-- +-- Check for cases where the actual corresponding to the access +-- parameter is: +-- (a) An allocator. +-- (b) An expression of a named access type. +-- (c) Obj'Access. +-- +-- TEST DESCRIPTION: +-- In order to satisfy accessibility requirements, the operand type +-- must be at the same or a less deep nesting level than the target +-- type -- the operand type must "live" as long as the target type. +-- Nesting levels are the run-time nestings of masters: block statements; +-- subprogram, task, and entry bodies; and accept statements. Packages +-- are invisible to accessibility rules. +-- +-- This test declares subprograms with access parameters, within which +-- a type conversion is attempted on the access parameter to an access +-- type A declared at some nesting level. The test verifies that +-- Program_Error is raised if the actual corresponding to the access +-- parameter is: +-- +-- (1) an allocator, and the accessibility level of the execution +-- of the called subprogram is deeper than that of the access +-- type A. +-- +-- (2) an expression of a named access type, and the accessibility +-- level of the named access type is deeper than that of the +-- access type A. +-- +-- (3) a reference to the Access attribute (e.g., X'Access), and +-- the accessibility level of X is deeper than that of the +-- access type A. +-- +-- Note that the static nesting level of the actual corresponding to the +-- access parameter can be deeper than that of the target type -- it is +-- the run-time nesting that matters for accessibility rules. Consider +-- the case where the access type A is declared within the called +-- subprogram. The accessibility check will never fail, even if the +-- actual happens to have a deeper static nesting level: +-- +-- procedure P (X: access T) is +-- type A is access all T; -- Static level = 2, e.g. +-- Acc : A := A(X); -- Check should never fail. +-- begin null; end; +-- . . . +-- declare +-- Actual : aliased T; -- Static level = 3, e.g. +-- begin +-- P (Actual'Access); +-- end; +-- +-- For the execution of P, the accessibility level of type A will +-- always be deeper than that of Actual, so there is no danger of a +-- dangling reference arising from the assignment to Acc. Thus, the +-- type conversion is safe, even though the static nesting level of +-- Actual is deeper than that of A. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C460001_0 is + + type Desig is array (1 .. 10) of Integer; + + X0 : aliased Desig; -- Level = 0. + + type Acc_L0 is access all Desig; -- Level = 0. + A0 : Acc_L0; + + type Result_Kind is (OK, P_E, O_E); + + procedure Target_Is_Level_0 (X: access Desig; R : out Result_Kind); + procedure Never_Fails (X: access Desig; R : out Result_Kind); + +end C460001_0; + + + --==================================================================-- + + +package body C460001_0 is + + procedure Target_Is_Level_0 (X : access Desig; + R : out Result_Kind) is + begin + -- The accessibility level of type Acc_L0 is 0. + A0 := Acc_L0(X); + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Target_Is_Level_0; + + ----------------------------------------------- + procedure Never_Fails (X: access Desig; + R : out Result_Kind) is + type Acc_Local is access all Desig; + AL : Acc_Local; + begin + -- The type conversion below will always be safe, since the + -- accessibility level (although not necessarily the static nesting + -- depth) of Acc_Local will always be deeper than or the same as that + -- of the actual corresponding to X. + AL := Acc_Local(X); + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Never_Fails; + +end C460001_0; + + + --==================================================================-- + + +with C460001_0; +with Report; + +procedure C460001 is + + X1 : aliased C460001_0.Desig; -- Level = 1. + + type Acc_L1 is access all C460001_0.Desig; -- Level = 1. + A1 : Acc_L1; + + Expr_L0 : C460001_0.Acc_L0 := C460001_0.X0'Access; + Expr_L1 : Acc_L1 := X1'Access; + + Res : C460001_0.Result_Kind; + + use type C460001_0.Result_Kind; + + ----------------------------------------------- + procedure Target_Is_Level_1 (X : access C460001_0.Desig; + R : out C460001_0.Result_Kind) is + begin + -- The accessibility level of type Acc_L1 is 1. + A1 := Acc_L1(X); + R := C460001_0.OK; + exception + when Program_Error => + R := C460001_0.P_E; + when others => + R := C460001_0.O_E; + end Target_Is_Level_1; + + ----------------------------------------------- + procedure Display_Results (Result : in C460001_0.Result_Kind; + Expected: in C460001_0.Result_Kind; + Message : in String) is + begin + if Result /= Expected then + case Result is + when C460001_0.OK => Report.Failed ("No exception raised: " & + Message); + when C460001_0.P_E => Report.Failed ("Program_Error raised: " & + Message); + when C460001_0.O_E => Report.Failed ("Unexpected exception " & + "raised: " & Message); + end case; + end if; + end Display_Results; + +begin -- C460001 + + Report.Test ("C460001", "Check that if the target type of a type " & + "conversion is a general access type, Program_Error is " & + "raised if the accessibility level of the operand type " & + "is deeper than that of the target type: operand is an " & + "access parameter; corresponding actual is an allocator, " & + "expression of a named access type, Obj'Access"); + + + -- Actual is X'Access: + + C460001_0.Never_Fails (X1'Access, Res); + Display_Results (Res, C460001_0.OK, "X1'Access, local access type"); + + C460001_0.Target_Is_Level_0 (X1'Access, Res); + Display_Results (Res, C460001_0.P_E, "X1'Access, level 0 access type"); + + Target_Is_Level_1 (C460001_0.X0'Access, Res); + Display_Results (Res, C460001_0.OK, "X0'Access, level 1 access type"); + + Target_Is_Level_1 (X1'Access, Res); + Display_Results (Res, C460001_0.OK, "X1'Access, level 1 access type"); + + C460001_0.Target_Is_Level_0 (C460001_0.X0'Access, Res); + Display_Results (Res, C460001_0.OK, "X0'Access, level 0 access type"); + + + -- Actual is expression of a named access type: + + C460001_0.Never_Fails (Expr_L0, Res); + Display_Results (Res, C460001_0.OK, "Expr_L0, local access type"); + + C460001_0.Target_Is_Level_0 (Expr_L0, Res); + Display_Results (Res, C460001_0.OK, "Expr_L0, level 0 access type"); + + C460001_0.Target_Is_Level_0 (Expr_L1, Res); + Display_Results (Res, C460001_0.P_E, "Expr_L1, level 0 access type"); + + Target_Is_Level_1 (Expr_L1, Res); + Display_Results (Res, C460001_0.OK, "Expr_L1, level 1 access type"); + + Target_Is_Level_1 (Expr_L0, Res); + Display_Results (Res, C460001_0.OK, "Expr_L0, level 1 access type"); + + -- Actual is allocator (level of execution = 2): + + C460001_0.Never_Fails (new C460001_0.Desig, Res); + Display_Results (Res, C460001_0.OK, "Allocator level 2, " & + "local access type"); + + C460001_0.Target_Is_Level_0 (new C460001_0.Desig, Res); + Display_Results (Res, C460001_0.P_E, "Allocator level 2, " & + "level 0 access type"); + + Target_Is_Level_1 (new C460001_0.Desig, Res); + Display_Results (Res, C460001_0.P_E, "Allocator level 2, " & + "level 1 access type"); + + + Block_L2: + declare + X2 : aliased C460001_0.Desig; -- Level = 2. + type Acc_L2 is access all C460001_0.Desig; -- Level = 2. + Expr_L2 : Acc_L2 := X1'Access; + begin + + -- Actual is X'Access: + + C460001_0.Never_Fails (X2'Access, Res); + Display_Results (Res, C460001_0.OK, "X2'Access, local access type"); + + Target_Is_Level_1 (X2'Access, Res); + Display_Results (Res, C460001_0.P_E, "X2'Access, level 1 access type"); + + -- Actual is expression of a named access type: + + C460001_0.Never_Fails (Expr_L2, Res); + Display_Results (Res, C460001_0.OK, "Expr_L2, local access type"); + + C460001_0.Target_Is_Level_0 (Expr_L2, Res); + Display_Results (Res, C460001_0.P_E, "Expr_L2, level 0 access type"); + + + -- Actual is allocator (level of execution = 3): + + C460001_0.Never_Fails (new C460001_0.Desig, Res); + Display_Results (Res, C460001_0.OK, "Allocator level 3, " & + "local access type"); + + Target_Is_Level_1 (new C460001_0.Desig, Res); + Display_Results (Res, C460001_0.P_E, "Allocator level 3, " & + "level 1 access type"); + + end Block_L2; + + Report.Result; + +end C460001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460002.a b/gcc/testsuite/ada/acats/tests/c4/c460002.a new file mode 100644 index 000000000..945dd5677 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460002.a @@ -0,0 +1,330 @@ +-- C460002.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 if the target type of a type conversion is a general +-- access type, Program_Error is raised if the accessibility level +-- of the operand type is deeper than that of the target type. +-- Check for the case where the operand is an access parameter, +-- and the actual corresponding to the access parameter is another +-- access parameter. +-- +-- TEST DESCRIPTION: +-- In order to satisfy accessibility requirements, the operand type +-- must be at the same or a less deep nesting level than the target +-- type -- the operand type must "live" as long as the target type. +-- Nesting levels are the run-time nestings of masters: block statements; +-- subprogram, task, and entry bodies; and accept statements. Packages +-- are invisible to accessibility rules. +-- +-- This test declares subprograms with access parameters, within which +-- a type conversion is attempted on the access parameter to an access +-- type A declared at some nesting level. The test verifies that +-- Program_Error is raised if the actual corresponding to the access +-- parameter is another access parameter, and the actual corresponding +-- to this second access parameter is: +-- +-- (1) an expression of a named access type, and the accessibility +-- level of the named access type is deeper than that of the +-- access type A. +-- +-- (2) a reference to the Access attribute (e.g., X'Access), and +-- the accessibility level of X is deeper than that of the +-- access type A. +-- +-- Note that the static nesting level of the actual corresponding to the +-- access parameter can be deeper than that of the target type -- it is +-- the run-time nesting that matters for accessibility rules. Consider +-- the case where the access type A is declared within the called +-- subprogram. The accessibility check will never fail, even if the +-- actual happens to have a deeper static nesting level: +-- +-- procedure P (X: access T) is +-- type A is access all T; -- Static level = 2, e.g. +-- Acc : A := A(X); -- Check should never fail. +-- begin null; end; +-- . . . +-- procedure Q (Y: access T) is +-- begin +-- P(Y); +-- end; +-- . . . +-- declare +-- Actual : aliased T; -- Static level = 3, e.g. +-- begin +-- Q (Actual'Access); +-- end; +-- +-- For the execution of Q (and hence P), the accessibility level of +-- type A will always be deeper than that of Actual, so there is no +-- danger of a dangling reference arising from the assignment to +-- Acc. Thus, the type conversion is safe, even though the static +-- nesting level of Actual is deeper than that of A. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Changed maintenance documentation. +-- 15 Jul 98 EDS Avoid Optimization +-- 28 Jun 02 RLB Added pragma Elaborate_All. +--! + +with Report; use Report; pragma Elaborate_All (Report); +package C460002_0 is + + type Component is array (1 .. 10) of Natural; + + type Desig is record + C: Component; + end record; + + X0 : aliased Desig := (C=>(others => Ident_Int(3))); -- Level = 0. + + type Acc_L0 is access all Desig; -- Level = 0. + A0 : Acc_L0; + + type Result_Kind is (OK, P_E, O_E); + + procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind); + procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind); + procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind); + +end C460002_0; + + + --==================================================================-- + + +package body C460002_0 is + + procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind) is + + procedure Nested (X: access Desig; R: out Result_Kind) is + -- This procedure attempts a type conversion on the access parameter to + -- an access type declared at some nesting level. Program_Error is + -- raised if the accessibility level of the operand type is deeper than + -- that of the target type. + + begin + -- The accessibility level of type Acc_L0 is 0. + A0 := Acc_L0(X); + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Nested; + + begin + Nested (Y, S); + end Target_Is_Level_0_Nest; + + ------------------------------------------------------------- + + procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind) is + + type Acc_Deeper is access all Desig; + AD : Acc_Deeper; + + function Nested (X: access Desig) return Result_Kind is + begin + -- The type conversion below will always be safe, since the + -- accessibility level (although not necessarily the static nesting + -- depth) of Acc_Deeper will always be deeper than or the same as that + -- of the actual corresponding to Y. + AD := Acc_Deeper(X); + if Natural(Ident_Int(AD.C(1))) /= 3 then --Avoid Optimization of AD + Report.Failed ("Initial Values not correct."); + end if; + return OK; + exception + when Program_Error => + return P_E; + when others => + return O_E; + end Nested; + + begin + S := Nested (Y); + end Never_Fails_Nest; + + ------------------------------------------------------------- + + procedure Called_By_Never_Fails_Same + (X: access Desig; R: out Result_Kind) is + type Acc_Local is access all Desig; + AL : Acc_Local; + begin + -- The type conversion below will always be safe, since the + -- accessibility level (although not necessarily the static nesting + -- depth) of Acc_Local will always be deeper than or the same as that + -- of the actual corresponding to X. + AL := Acc_Local(X); + if Natural(Ident_Int(AL.C(1))) /= 3 then --Avoid Optimization of AL + Report.Failed ("Initial Values not correct."); + end if; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Called_By_Never_Fails_Same; + + ------------------------------------------------------------- + + procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind) is + begin + Called_By_Never_Fails_Same (Y, S); + end Never_Fails_Same; + +end C460002_0; + + + --==================================================================-- + + +with C460002_0; +use C460002_0; + +with Report; use Report; + +procedure C460002 is + + type Acc_L1 is access all Desig; -- Level = 1. + A1 : Acc_L1; + X1 : aliased Desig := (C=>(others => Ident_Int(3))); + Res : Result_Kind; + + + + procedure Called_By_Target_L1 (X: access Desig; R: out Result_Kind) is + begin + -- The accessibility level of type Acc_L1 is 1. + A1 := Acc_L1(X); + if Natural(Ident_Int(A1.C(1))) /= 3 then --Avoid Optimization of A1 + Report.Failed ("Initial Values not correct."); + end if; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Called_By_Target_L1; + + ------------------------------------------------------------- + + function Target_Is_Level_1_Same (Y: access Desig) return Result_Kind is + S : Result_Kind; + begin + Called_By_Target_L1 (Y, S); + return S; + end Target_Is_Level_1_Same; + + ------------------------------------------------------------- + + procedure Display_Results (Result : in Result_Kind; + Expected: in Result_Kind; + Msg : in String) is + begin + if Result /= Expected then + case Result is + when OK => Report.Failed ("No exception raised: " & Msg); + when P_E => Report.Failed ("Program_Error raised: " & Msg); + when O_E => Report.Failed ("Unexpected exception raised: " & Msg); + end case; + end if; + end Display_Results; + +begin -- C460002. + + Report.Test ("C460002", "Check that if the target type of a type " & + "conversion is a general access type, Program_Error is " & + "raised if the accessibility level of the operand type " & + "is deeper than that of the target type: operand is an " & + "access parameter; corresponding actual is another " & + "access parameter"); + + + -- Accessibility level of actual is 0 (actual is X'Access): + + Never_Fails_Same (X0'Access, Res); + Display_Results (Res, OK, "Never_Fails_Same, level 0 actual"); + + Never_Fails_Nest (X0'Access, Res); + Display_Results (Res, OK, "Target_L1_Nest, level 0 actual"); + + Target_Is_Level_0_Nest (X0'Access, Res); + Display_Results (Res, OK, "Target_L0_Nest, level 0 actual"); + + Res := Target_Is_Level_1_Same (X0'Access); + Display_Results (Res, OK, "Target_L1_Same, level 0 actual"); + + + -- Accessibility level of actual is 1 (actual is X'Access): + + Never_Fails_Same (X1'Access, Res); + Display_Results (Res, OK, "Never_Fails_Same, level 1 actual"); + + Never_Fails_Nest (X1'Access, Res); + Display_Results (Res, OK, "Target_L1_Nest, level 1 actual"); + + Target_Is_Level_0_Nest (X1'Access, Res); + Display_Results (Res, P_E, "Target_L0_Nest, level 1 actual"); + + Res := Target_Is_Level_1_Same (X1'Access); + Display_Results (Res, OK, "Target_L1_Same, level 1 actual"); + + + Block_L2: + declare + X2 : aliased Desig := (C=>(others => Ident_Int(3))); + type Acc_L2 is access all Desig; -- Level = 2. + Expr_L2 : Acc_L2 := X2'Access; + begin + + -- Accessibility level of actual is 2 (actual is expression of named + -- access type): + + Never_Fails_Same (Expr_L2, Res); + Display_Results (Res, OK, "Never_Fails_Same, level 2 actual"); + + Never_Fails_Nest (Expr_L2, Res); + Display_Results (Res, OK, "Target_L1_Nest, level 2 actual"); + + Target_Is_Level_0_Nest (Expr_L2, Res); + Display_Results (Res, P_E, "Target_L0_Nest, level 2 actual"); + + Res := Target_Is_Level_1_Same (Expr_L2); + Display_Results (Res, P_E, "Target_L1_Same, level 2 actual"); + + end Block_L2; + + + Report.Result; + +end C460002; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460004.a b/gcc/testsuite/ada/acats/tests/c4/c460004.a new file mode 100644 index 000000000..b00428121 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460004.a @@ -0,0 +1,335 @@ +-- C460004.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 if the operand type of a type conversion is class-wide, +-- Constraint_Error is raised if the tag of the operand does not +-- identify a specific type that is covered by or descended from the +-- target type. +-- +-- TEST DESCRIPTION: +-- View conversions of class-wide operands to specific types are +-- placed on the right and left sides of assignment statements, and +-- conversions of class-wide operands to class-wide types are used +-- as actual parameters to dispatching operations. In all cases, a +-- check is made that Constraint_Error is raised if the tag of the +-- operand does not identify a specific type covered by or descended +-- from the target type, and not raised otherwise. +-- +-- A specific type is descended from itself and from those types it is +-- directly or indirectly derived from. A specific type is covered by +-- itself and each class-wide type to whose class it belongs. +-- +-- A class-wide type T'Class is descended from T and those types which +-- T is descended from. A class-wide type is covered by each class-wide +-- type to whose class it belongs. +-- +-- +-- CHANGE HISTORY: +-- 19 Jul 95 SAIC Initial prerelease version. +-- 18 Apr 96 SAIC ACVC 2.1: Added a check for correct tag. +-- +--! +package C460004_0 is + + type Tag_Type is tagged record + C1 : Natural; + end record; + + procedure Proc (X : in out Tag_Type); + + + type DTag_Type is new Tag_Type with record + C2 : String (1 .. 5); + end record; + + procedure Proc (X : in out DTag_Type); + + + type DDTag_Type is new DTag_Type with record + C3 : String (1 .. 5); + end record; + + procedure Proc (X : in out DDTag_Type); + + procedure NewProc (X : in DDTag_Type); + + function CWFunc (X : Tag_Type'Class) return Tag_Type'Class; + +end C460004_0; + + + --==================================================================-- + +with Report; +package body C460004_0 is + + procedure Proc (X : in out Tag_Type) is + begin + X.C1 := 25; + end Proc; + + ----------------------------------------- + procedure Proc (X : in out DTag_Type) is + begin + Proc ( Tag_Type(X) ); + X.C2 := "Earth"; + end Proc; + + ----------------------------------------- + procedure Proc (X : in out DDTag_Type) is + begin + Proc ( DTag_Type(X) ); + X.C3 := "Orbit"; + end Proc; + + ----------------------------------------- + procedure NewProc (X : in DDTag_Type) is + Y : DDTag_Type := X; + begin + Proc (Y); + exception + when others => + Report.Failed ("Unexpected exception in NewProc"); + end NewProc; + + ----------------------------------------- + function CWFunc (X : Tag_Type'Class) return Tag_Type'Class is + Y : Tag_Type'Class := X; + begin + Proc (Y); + return Y; + end CWFunc; + +end C460004_0; + + + --==================================================================-- + + +with C460004_0; +use C460004_0; + +with Report; +procedure C460004 is + + Tag_Type_Init : constant Tag_Type := (C1 => 0); + DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello"); + DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World"); + + Tag_Type_Value : constant Tag_Type := (C1 => 25); + DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth"); + DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit"); + +begin + + Report.Test ("C460004", "Check that for a view conversion of a " & + "class-wide operand, Constraint_Error is raised if the " & + "tag of the operand does not identify a specific type " & + "covered by or descended from the target type"); + +-- +-- View conversion to specific type: +-- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Target : Tag_Type := Tag_Type_Init; + begin + Target := Tag_Type(P); + if (Target /= Tag_Type_Value) then + Report.Failed ("Target has wrong value: #01"); + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #01"); + when others => + Report.Failed ("Unexpected exception: #01"); + end CW_Proc; + + begin + CW_Proc (DDTag_Type_Value); + end; + + ---------------------------------------------------------------------- + + declare + Target : DTag_Type := DTag_Type_Init; + begin + Target := DTag_Type(CWFunc(DDTag_Type_Value)); + if (Target /= DTag_Type_Value) then + Report.Failed ("Target has wrong value: #02"); + end if; + exception + when Constraint_Error => Report.Failed ("Constraint_Error raised: #02"); + when others => Report.Failed ("Unexpected exception: #02"); + end; + + ---------------------------------------------------------------------- + + declare + Target : DDTag_Type; + begin + Target := DDTag_Type(CWFunc(Tag_Type_Value)); + -- CWFunc returns a Tag_Type; its tag is preserved through + -- the view conversion. Constraint_Error should be raised. + + Report.Failed ("Constraint_Error not raised: #03"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #03"); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + begin + NewProc (DDTag_Type(P)); + Report.Failed ("Constraint_Error not raised: #04"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #04"); + end CW_Proc; + + begin + CW_Proc (DTag_Type_Value); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Target : DDTag_Type := DDTag_Type_Init; + begin + Target := DDTag_Type(P); + if (Target /= DDTag_Type_Value) then + Report.Failed ("Target has wrong value: #05"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #05"); + when others + => Report.Failed ("Unexpected exception: #05"); + end CW_Proc; + + begin + CW_Proc (DDTag_Type_Value); + end; + + +-- +-- View conversion to class-wide type: +-- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Proc( DTag_Type'Class(Operand) ); + Report.Failed ("Constraint_Error not raised: #06"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #06"); + end CW_Proc; + + begin + CW_Proc (Tag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Proc( DDTag_Type'Class(Operand) ); + Report.Failed ("Constraint_Error not raised: #07"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #07"); + end CW_Proc; + + begin + CW_Proc (Tag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Proc( DTag_Type'Class(Operand) ); + if Operand not in DTag_Type then + Report.Failed ("Operand has wrong tag: #08"); + elsif (Operand /= Tag_Type'Class (DTag_Type_Value)) then + Report.Failed ("Operand has wrong value: #08"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #08"); + when others => + Report.Failed ("Unexpected exception: #08"); + end CW_Proc; + + begin + CW_Proc (DTag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Proc( Tag_Type'Class(Operand) ); + if Operand not in DDTag_Type then + Report.Failed ("Operand has wrong tag: #09"); + elsif (Operand /= Tag_Type'Class (DDTag_Type_Value)) then + Report.Failed ("Operand has wrong value: #09"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #09"); + when others => + Report.Failed ("Unexpected exception: #09"); + end CW_Proc; + + begin + CW_Proc (DDTag_Type_Init); + end; + + + Report.Result; + +end C460004; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460005.a b/gcc/testsuite/ada/acats/tests/c4/c460005.a new file mode 100644 index 000000000..95b14a9a2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460005.a @@ -0,0 +1,260 @@ +-- C460005.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 view conversion of a tagged type that is the left +-- side of an assignment statement, the assignment assigns to the +-- corresponding part of the object denoted by the operand. +-- +-- TEST DESCRIPTION: +-- View conversions of class-wide operands to specific types are +-- placed on the right and left sides of assignment statements, and +-- conversions of class-wide operands to class-wide types are used +-- as actual parameters to dispatching operations. In all cases, a +-- check is made that Constraint_Error is raised if the tag of the +-- operand does not identify a specific type covered by or descended +-- from the target type, and not raised otherwise. +-- +-- For the cases where the view conversion is the left side of an +-- assignment statement, and Constraint_Error should not be raised, +-- an additional check is made that only the corresponding portion +-- of the operand is updated by the assignment. For example: +-- +-- type T is tagged record +-- C1 : Integer := 0; +-- end record; +-- +-- type DT is new T with record +-- C2 : Integer := 0; +-- end record; +-- +-- A : T := (C1 => 5); +-- B : DT := (C1 => 0, C2 => 10); +-- CWDT : T'Class := B; +-- +-- T(CWDT) := A; -- Updates component C1; C2 remains unchanged. +-- -- Value of CWDT is (C1 => 5, C2 => 10). +-- +-- +-- CHANGE HISTORY: +-- 31 Jul 95 SAIC Initial prerelease version. +-- 22 Apr 96 SAIC ACVC 2.1: Added a check for correct tag. +-- 08 Sep 96 SAIC ACVC 2.1: Modified Report.Test. +-- +--! + +package C460005_0 is + + type Tag_Type is tagged record + C1 : Natural; + end record; + + procedure Proc (X : in out Tag_Type); + + + type DTag_Type is new Tag_Type with record + C2 : String (1 .. 5); + end record; + + procedure Proc (X : in out DTag_Type); + + + type DDTag_Type is new DTag_Type with record + C3 : String (1 .. 5); + end record; + + procedure Proc (X : in out DDTag_Type); + +end C460005_0; + + + --==================================================================-- + + +package body C460005_0 is + + procedure Proc (X : in out Tag_Type) is + begin + X.C1 := 25; + end Proc; + + ----------------------------------------- + procedure Proc (X : in out DTag_Type) is + begin + Proc ( Tag_Type(X) ); + X.C2 := "Earth"; + end Proc; + + ----------------------------------------- + procedure Proc (X : in out DDTag_Type) is + begin + Proc ( DTag_Type(X) ); + X.C3 := "Orbit"; + end Proc; + +end C460005_0; + + + --==================================================================-- + + +with C460005_0; +use C460005_0; + +with Report; +procedure C460005 is + + Tag_Type_Init : constant Tag_Type := (C1 => 0); + DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello"); + DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World"); + + Tag_Type_Value : constant Tag_Type := (C1 => 25); + DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth"); + DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit"); + + Tag_Type_Res : constant Tag_Type := (C1 => 25); + DTag_Type_Res : constant DTag_Type := (Tag_Type_Res with "Hello"); + DDTag_Type_Res : constant DDTag_Type := (DTag_Type_Res with "World"); + +begin + + Report.Test ("C460005", "Check that, for a view conversion of a tagged " & + "type that is the left side of an assignment statement, " & + "the assignment assigns to the corresponding part of the " & + "object denoted by the operand"); + + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Tag_Type(Operand) := Tag_Type_Value; + + if (Operand /= Tag_Type'Class (Tag_Type_Value)) then + Report.Failed ("Operand has wrong value: #01"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #01"); + when others => + Report.Failed ("Unexpected exception: #01"); + end CW_Proc; + + begin + CW_Proc (Tag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + DTag_Type(Operand) := DTag_Type_Value; + Report.Failed ("Constraint_Error not raised: #02"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #02"); + end CW_Proc; + + begin + CW_Proc (Tag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + DDTag_Type(Operand) := DDTag_Type_Value; + Report.Failed ("Constraint_Error not raised: #03"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #03"); + end CW_Proc; + + begin + CW_Proc (Tag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Tag_Type(Operand) := Tag_Type_Value; + + if Operand not in DTag_Type then + Report.Failed ("Operand has wrong tag: #04"); + elsif (Operand /= Tag_Type'Class (DTag_Type_Res)) + then -- Check to make + Report.Failed ("Operand has wrong value: #04"); -- sure that C2 was + end if; -- not modified. + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #04"); + when others => + Report.Failed ("Unexpected exception: #04"); + end CW_Proc; + + begin + CW_Proc (DTag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Tag_Type(Operand) := Tag_Type_Value; + + if Operand not in DDTag_Type then + Report.Failed ("Operand has wrong tag: #05"); + elsif (Operand /= Tag_Type'Class (DDTag_Type_Res)) + then -- Check to make + Report.Failed ("Operand has wrong value: #05"); -- sure that C2, C3 + end if; -- were not changed. + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #05"); + when others => + Report.Failed ("Unexpected exception: #05"); + end CW_Proc; + + begin + CW_Proc (DDTag_Type_Init); + end; + + Report.Result; + +end C460005; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460006.a b/gcc/testsuite/ada/acats/tests/c4/c460006.a new file mode 100644 index 000000000..99968847b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460006.a @@ -0,0 +1,378 @@ +-- C460006.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a view conversion to a tagged type is permitted in the +-- prefix of a selected component, an object renaming declaration, and +-- (if the operand is a variable) on the left side of an assignment +-- statement. Check that such a renaming or assignment does not change +-- the tag of the operand. +-- +-- Check that, for a view conversion of a tagged type, each +-- nondiscriminant component of the new view denotes the matching +-- component of the operand object. Check that reading the value of the +-- view yields the result of converting the value of the operand object +-- to the target subtype. +-- +-- TEST DESCRIPTION: +-- The fact that the tag of an object is not changed is verified by +-- making calls to primitive operations which in turn make (re)dispatching +-- calls, and confirming that the proper bodies are executed. +-- +-- Selected components are checked in three contexts: as the object name +-- in an object renaming declaration, as the left operand of an inequality +-- operation, and as the left side of an assignment statement. +-- +-- View conversions of an object of a 2nd level type extension are +-- renamed as objects of an ancestor type and of a class-wide type. In +-- one case the operand of the conversion is itself a renaming of an +-- object. +-- +-- View conversions of an object of a 2nd level type extension are +-- checked for equality with record aggregates of various ancestor types. +-- In one case, the view conversion is to a class-wide type, and it is +-- checked for equality with the result of a class-wide function with +-- the following structure: +-- +-- function F return T'Class is +-- A : DDT := Expected_Value; +-- X : T'Class := T(A); +-- begin +-- return X; +-- +-- end F; +-- +-- ... +-- +-- Var : DDT := Expected_Value; +-- +-- if (T'Class(Var) /= F) then -- Condition should yield FALSE. +-- FAIL; +-- end if; +-- +-- The view conversion to which X is initialized does not affect the +-- value or tag of the operand; the tag of X is that of type DDT (not T), +-- and the components are those of A. The result of this function +-- should equal the value of an object of type DDT initialized to the +-- same value as F.A. +-- +-- To check that assignment to a view conversion does not change the tag +-- of the operand, an assignment is made to a conversion of an object, +-- and the object is then passed as an actual to a dispatching operation. +-- Conversions to both specific and class-wide types are checked. +-- +-- +-- CHANGE HISTORY: +-- 20 Jul 95 SAIC Initial prerelease version. +-- 24 Apr 96 SAIC Added type conversions. +-- +--! + +package C460006_0 is + + type Call_ID_Kind is (None, Parent_Outer, Parent_Inner, + Child_Outer, Child_Inner, + Grandchild_Outer, Grandchild_Inner); + + type Root_Type is abstract tagged record + First_Call : Call_ID_Kind := None; + Second_Call : Call_ID_Kind := None; + end record; + + procedure Inner_Proc (X : in out Root_Type) is abstract; + procedure Outer_Proc (X : in out Root_Type) is abstract; + +end C460006_0; + + + --==================================================================-- + + +package C460006_0.C460006_1 is + + type Parent_Type is new Root_Type with record + C1 : Integer := 0; + end record; + + procedure Inner_Proc (X : in out Parent_Type); + procedure Outer_Proc (X : in out Parent_Type); + +end C460006_0.C460006_1; + + + --==================================================================-- + + +package body C460006_0.C460006_1 is + + procedure Inner_Proc (X : in out Parent_Type) is + begin + X.Second_Call := Parent_Inner; + end Inner_Proc; + + ------------------------------------------------- + procedure Outer_Proc (X : in out Parent_Type) is + begin + X.First_Call := Parent_Outer; + Inner_Proc ( Parent_Type'Class(X) ); + end Outer_Proc; + +end C460006_0.C460006_1; + + + --==================================================================-- + + +package C460006_0.C460006_1.C460006_2 is + + type Child_Type is new Parent_Type with record + C2 : String(1 .. 5) := "-----"; + end record; + + procedure Inner_Proc (X : in out Child_Type); + procedure Outer_Proc (X : in out Child_Type); + +end C460006_0.C460006_1.C460006_2; + + + --==================================================================-- + + +package body C460006_0.C460006_1.C460006_2 is + + procedure Inner_Proc (X : in out Child_Type) is + begin + X.Second_Call := Child_Inner; + end Inner_Proc; + + ------------------------------------------------- + procedure Outer_Proc (X : in out Child_Type) is + begin + X.First_Call := Child_Outer; + Inner_Proc ( Parent_Type'Class(X) ); + end Outer_Proc; + +end C460006_0.C460006_1.C460006_2; + + + --==================================================================-- + + +package C460006_0.C460006_1.C460006_2.C460006_3 is + + type Grandchild_Type is new Child_Type with record + C3: String(1 .. 5) := "-----"; + end record; + + procedure Inner_Proc (X : in out Grandchild_Type); + procedure Outer_Proc (X : in out Grandchild_Type); + + + function ClassWide_Func return Parent_Type'Class; + + + Grandchild_Value : constant Grandchild_Type := (First_Call => None, + Second_Call => None, + C1 => 15, + C2 => "Hello", + C3 => "World"); + +end C460006_0.C460006_1.C460006_2.C460006_3; + + + --==================================================================-- + + +package body C460006_0.C460006_1.C460006_2.C460006_3 is + + procedure Inner_Proc (X : in out Grandchild_Type) is + begin + X.Second_Call := Grandchild_Inner; + end Inner_Proc; + + ------------------------------------------------- + procedure Outer_Proc (X : in out Grandchild_Type) is + begin + X.First_Call := Grandchild_Outer; + Inner_Proc ( Parent_Type'Class(X) ); + end Outer_Proc; + + ------------------------------------------------- + function ClassWide_Func return Parent_Type'Class is + A : Grandchild_Type := Grandchild_Value; + X : Parent_Type'Class := Parent_Type(A); -- Value of X is still that of A. + begin + return X; + end ClassWide_Func; + +end C460006_0.C460006_1.C460006_2.C460006_3; + + + --==================================================================-- + + +with C460006_0.C460006_1.C460006_2.C460006_3; + +with Report; +procedure C460006 is + + package Root_Package renames C460006_0; + package Parent_Package renames C460006_0.C460006_1; + package Child_Package renames C460006_0.C460006_1.C460006_2; + package Grandchild_Package renames C460006_0.C460006_1.C460006_2.C460006_3; + +begin + Report.Test ("C460006", "Check that a view conversion to a tagged type " & + "is permitted in the prefix of a selected component, an " & + "object renaming declaration, and (if the operand is a " & + "variable) on the left side of an assignment statement. " & + "Check that such a renaming or assignment does not change " & + " the tag of the operand"); + + + -- + -- Check conversion as prefix of selected component: + -- + + Selected_Component_Subtest: + declare + use Root_Package, Parent_Package, Child_Package, Grandchild_Package; + + Var : Grandchild_Type := Grandchild_Value; + CW_Var : Parent_Type'Class := Var; + + Ren : Integer renames Parent_Type(Var).C1; + + begin + if Ren /= 15 then + Report.Failed ("Wrong value: selected component in renaming"); + end if; + + if Child_Type(Var).C2 /= "Hello" then + Report.Failed ("Wrong value: selected component in IF"); + end if; + + Grandchild_Type(CW_Var).C3(2..4) := "eir"; + if CW_Var /= Parent_Type'Class + (Grandchild_Type'(None, None, 15, "Hello", "Weird")) + then + Report.Failed ("Wrong value: selected component in assignment"); + end if; + end Selected_Component_Subtest; + + + -- + -- Check conversion in object renaming: + -- + + Object_Renaming_Subtest: + declare + use Root_Package, Parent_Package, Child_Package, Grandchild_Package; + + Var : Grandchild_Type := Grandchild_Value; + Ren1 : Parent_Type renames Parent_Type(Var); + Ren2 : Child_Type renames Child_Type(Var); + Ren3 : Parent_Type'Class renames Parent_Type'Class(Var); + Ren4 : Parent_Type renames Parent_Type(Ren2); -- Rename of rename. + begin + Outer_Proc (Ren1); + if Ren1 /= (Parent_Outer, Grandchild_Inner, 15) then + Report.Failed ("Value or tag not preserved by object renaming: Ren1"); + end if; + + Outer_Proc (Ren2); + if Ren2 /= (Child_Outer, Grandchild_Inner, 15, "Hello") then + Report.Failed ("Value or tag not preserved by object renaming: Ren2"); + end if; + + Outer_Proc (Ren3); + if Ren3 /= Parent_Type'Class + (Grandchild_Type'(Grandchild_Outer, + Grandchild_Inner, + 15, + "Hello", + "World")) + then + Report.Failed ("Value or tag not preserved by object renaming: Ren3"); + end if; + + Outer_Proc (Ren4); + if Ren4 /= (Parent_Outer, Grandchild_Inner, 15) then + Report.Failed ("Value or tag not preserved by object renaming: Ren4"); + end if; + end Object_Renaming_Subtest; + + + -- + -- Check reading view conversion, and conversion as left side of assignment: + -- + + View_Conversion_Subtest: + declare + use Root_Package, Parent_Package, Child_Package, Grandchild_Package; + + Var : Grandchild_Type := Grandchild_Value; + Specific : Child_Type; + ClassWide : Parent_Type'Class := Var; -- Grandchild_Type tag. + begin + if Parent_Type(Var) /= (None, None, 15) then + Report.Failed ("View has wrong value: #1"); + end if; + + if Child_Type(Var) /= (None, None, 15, "Hello") then + Report.Failed ("View has wrong value: #2"); + end if; + + if Parent_Type'Class(Var) /= ClassWide_Func then + Report.Failed ("Upward view conversion did not preserve " & + "extension's components"); + end if; + + + Parent_Type(Specific) := (None, None, 26); -- Assign to view. + Outer_Proc (Specific); -- Call dispatching op. + + if Specific /= (Child_Outer, Child_Inner, 26, "-----") then + Report.Failed ("Value or tag not preserved by assignment: Specific"); + end if; + + + Parent_Type(ClassWide) := (None, None, 44); -- Assign to view. + Outer_Proc (ClassWide); -- Call dispatching op. + + if ClassWide /= Parent_Type'Class + (Grandchild_Type'(Grandchild_Outer, + Grandchild_Inner, + 44, + "Hello", + "World")) + then + Report.Failed ("Value or tag not preserved by assignment: ClassWide"); + end if; + end View_Conversion_Subtest; + + Report.Result; + +end C460006; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460007.a b/gcc/testsuite/ada/acats/tests/c4/c460007.a new file mode 100644 index 000000000..fdcc1adcc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460007.a @@ -0,0 +1,239 @@ +-- C460007.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, in a numeric type conversion, if the target type is an +-- integer type and the operand type is real, the result is rounded +-- to the nearest integer, and away from zero if the result is exactly +-- halfway between two integers. Check for static and non-static type +-- conversions. +-- +-- TEST DESCRIPTION: +-- The following cases are considered: +-- +-- X.5 X.5 + delta -X.5 + delta +-- -X.5 X.5 - delta -X.5 - delta +-- +-- Both zero and non-zero values are used for X. The value of delta is +-- chosen to be a very small increment (on the order of 1.0E-10). For +-- fixed and floating point cases, the value of delta is chosen such that +-- "(-)X.5 +(-) delta" is a multiple of the small, or a machine number, +-- respectively. +-- +-- The following type conversions are performed: +-- +-- ID Real operand Cases Target integer subtype +-- ------------------------------------------------------------------ +-- 1 Real named number X.5 Nonstatic +-- 2 X.5 - delta Nonstatic +-- 3 -X.5 - delta Static +-- 4 Real literal -X.5 Static +-- 5 X.5 + delta Static +-- 6 -X.5 + delta Nonstatic +-- 7 Floating point object -X.5 - delta Nonstatic +-- 8 X.5 - delta Static +-- 9 Fixed point object X.5 Static +-- 10 X.5 + delta Static +-- 11 -X.5 + delta Nonstatic +-- The conversion is either assigned to a variable of the target subtype +-- or passed as a parameter to a subprogram (both nonstatic contexts). +-- +-- The subprogram Equal is used to circumvent potential optimizations. +-- +-- +-- CHANGE HISTORY: +-- 03 Oct 95 SAIC Initial prerelease version. +-- +--! + +with System; +package C460007_0 is + +-- +-- Target integer subtype (static): +-- + + type Static_Integer_Subtype is range -32_000 .. 32_000; + + Static_Target : Static_Integer_Subtype; + + function Equal (L, R: Static_Integer_Subtype) return Boolean; + + +-- +-- Named numbers: +-- + + NN_Half : constant := 0.5000000000; + NN_Less_Half : constant := 126.4999999999; + NN_More_Half : constant := -NN_Half - 0.0000000001; + + +-- +-- Floating point: +-- + + type My_Float is digits System.Max_Digits; + + Flt_Rnd_Toward_Zero : My_Float := My_Float'Pred(NN_Half); + Flt_Rnd_Away_Zero : constant My_Float := My_Float'Pred(-113.5); + + +-- +-- Fixed point: +-- + + type My_Fixed is delta 0.1 range -5.0 .. 5.0; + + Fix_Half : My_Fixed := 0.5; + Fix_Rnd_Away_Zero : My_Fixed := Fix_Half + My_Fixed'Small; + Fix_Rnd_Toward_Zero : constant My_Fixed := -3.5 + My_Fixed'Small; + +end C460007_0; + + + --==================================================================-- + + +package body C460007_0 is + + function Equal (L, R: Static_Integer_Subtype) return Boolean is + begin + return (L = R); + end Equal; + +end C460007_0; + + + --==================================================================-- + + +with C460007_0; +use C460007_0; + +with Report; +procedure C460007 is + +-- +-- Target integer subtype (nonstatic): +-- + + Limit : Static_Integer_Subtype := + Static_Integer_Subtype(Report.Ident_Int(128)); + + subtype Nonstatic_Integer_Subtype is Static_Integer_Subtype + range -Limit .. Limit; + + Nonstatic_Target : Static_Integer_Subtype; + +begin + + Report.Test ("C460007", "Rounding for type conversions of real operand " & + "to integer target"); + + + -- -------------------------- + -- Named number/literal cases: + -- -------------------------- + + Nonstatic_Target := Nonstatic_Integer_Subtype(NN_Half); + + if not Equal(Nonstatic_Target, 1) then -- Case 1. + Report.Failed ("Wrong result for named number operand" & + "(case 1), nonstatic target subtype"); + end if; + + if not Equal(Nonstatic_Integer_Subtype(NN_Less_Half), 126) then -- Case 2. + Report.Failed ("Wrong result for named number operand" & + "(case 2), nonstatic target subtype"); + end if; + + Static_Target := Static_Integer_Subtype(NN_More_Half); + + if not Equal(Static_Target, -1) then -- Case 3. + Report.Failed ("Wrong result for named number operand" & + "(case 3), static target subtype"); + end if; + + if not Equal(Static_Integer_Subtype(-0.50), -1) then -- Case 4. + Report.Failed ("Wrong result for literal operand" & + "(case 4), static target subtype"); + end if; + + if not Equal(Static_Integer_Subtype(29_546.5001), 29_547) then -- Case 5. + Report.Failed ("Wrong result for literal operand" & + "(case 5), static target subtype"); + end if; + + if not Equal(Nonstatic_Integer_Subtype(-66.499), -66) then -- Case 6. + Report.Failed ("Wrong result for literal operand" & + "(case 6), nonstatic target subtype"); + end if; + + + -- -------------------- + -- Floating point cases: + -- -------------------- + + Nonstatic_Target := Nonstatic_Integer_Subtype(Flt_Rnd_Away_Zero); + + if not Equal(Nonstatic_Target, -114) then -- Case 7. + Report.Failed ("Wrong result for floating point operand" & + "(case 7), nonstatic target subtype"); + end if; + -- Case 8. + if not Equal(Static_Integer_Subtype(Flt_Rnd_Toward_Zero), 0) then + Report.Failed ("Wrong result for floating point operand" & + "(case 8), static target subtype"); + end if; + + + -- ----------------- + -- Fixed point cases: + -- ----------------- + + Static_Target := Static_Integer_Subtype(Fix_Half); + + if not Equal(Static_Target, 1) then -- Case 9. + Report.Failed ("Wrong result for fixed point operand" & + "(case 9), static target subtype"); + end if; + + if not Equal(Static_Integer_Subtype(Fix_Rnd_Away_Zero), 1) then -- Case 10. + Report.Failed ("Wrong result for fixed point operand" & + "(case 10), static target subtype"); + end if; + + Nonstatic_Target := Nonstatic_Integer_Subtype(Fix_Rnd_Toward_Zero); + + if not Equal(Nonstatic_Target, -3) then -- Case 11. + Report.Failed ("Wrong result for fixed point operand" & + "(case 11), nonstatic target subtype"); + end if; + + + Report.Result; + +end C460007; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460008.a b/gcc/testsuite/ada/acats/tests/c4/c460008.a new file mode 100644 index 000000000..29d48ecd4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460008.a @@ -0,0 +1,286 @@ +-- C460008.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 conversion to a modular type raises Constraint_Error +-- when the operand value is outside the base range of the modular type. +-- +-- TEST DESCRIPTION: +-- Test conversion from integer, float, fixed and decimal types to +-- modular types. Test conversion to mod 255, mod 256 and mod 258 +-- to test the boundaries of 8 bit (+/-) unsigned numbers. +-- Test operand values that are negative, the value of the mod, +-- and greater than the value of the mod. +-- Declare a generic test procedure and instantiate it for each of the +-- unsigned types for each operand type. +-- +-- +-- CHANGE HISTORY: +-- 04 OCT 95 SAIC Initial version +-- 15 MAY 96 SAIC Revised for 2.1 +-- 24 NOV 98 RLB Moved decimal cases into new test, C460011, to +-- prevent this test from being inapplicable to +-- implementations not supporting decimal types. +-- +--! + +------------------------------------------------------------------- C460008 + +with Report; + +procedure C460008 is + + Shy_By_One : constant := 2**8-1; + Heavy_By_Two : constant := 2**8+2; + + type Unsigned_Edge_8 is mod Shy_By_One; + type Unsigned_8_Bit is mod 2**8; + type Unsigned_Over_8 is mod Heavy_By_Two; + + NPC : constant String := " not properly converted"; + + procedure Assert( Truth: Boolean; Message: String ) is + begin + if not Truth then + Report.Failed(Message); + end if; + end Assert; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + generic + type Source is range <>; + type Target is mod <>; + procedure Integer_Conversion_Check( For_The_Value : Source; + Message : String ); + + procedure Integer_Conversion_Check( For_The_Value : Source; + Message : String ) is + + Item : Target; + + begin + Item := Target( For_The_Value ); + Report.Failed("Int expected Constraint_Error " & Message); + -- the call to Comment is to make the otherwise dead assignment to + -- Item live. + -- To avoid invoking C_E on a call to 'Image in Report.Failed that + -- could cause a false pass + Report.Comment("Value of" & Target'Image(Item) & NPC); + exception + when Constraint_Error => null; -- expected case + when others => Report.Failed("Int Raised wrong exception " & Message); + end Integer_Conversion_Check; + + procedure Int_To_Short is + new Integer_Conversion_Check( Integer, Unsigned_Edge_8 ); + + procedure Int_To_Eight is + new Integer_Conversion_Check( Integer, Unsigned_8_Bit ); + + procedure Int_To_Wide is + new Integer_Conversion_Check( Integer, Unsigned_Over_8 ); + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + generic + type Source is digits <>; + type Target is mod <>; + procedure Float_Conversion_Check( For_The_Value : Source; + Message : String ); + + procedure Float_Conversion_Check( For_The_Value : Source; + Message : String ) is + + Item : Target; + + begin + Item := Target( For_The_Value ); + Report.Failed("Flt expected Constraint_Error " & Message); + Report.Comment("Value of" & Target'Image(Item) & NPC); + exception + when Constraint_Error => null; -- expected case + when others => Report.Failed("Flt raised wrong exception " & Message); + end Float_Conversion_Check; + + procedure Float_To_Short is + new Float_Conversion_Check( Float, Unsigned_Edge_8 ); + + procedure Float_To_Eight is + new Float_Conversion_Check( Float, Unsigned_8_Bit ); + + procedure Float_To_Wide is + new Float_Conversion_Check( Float, Unsigned_Over_8 ); + + function Identity( Root_Beer: Float ) return Float is + -- a knockoff of Report.Ident_Int for type Float + Nothing : constant Float := 0.0; + begin + if Report.Ident_Bool( Root_Beer = Nothing ) then + return Nothing; + else + return Root_Beer; + end if; + end Identity; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + generic + type Source is delta <>; + type Target is mod <>; + procedure Fixed_Conversion_Check( For_The_Value : Source; + Message : String ); + + procedure Fixed_Conversion_Check( For_The_Value : Source; + Message : String ) is + + Item : Target; + + begin + Item := Target( For_The_Value ); + Report.Failed("Fix expected Constraint_Error " & Message); + Report.Comment("Value of" & Target'Image(Item) & NPC); + exception + when Constraint_Error => null; -- expected case + when others => Report.Failed("Fix raised wrong exception " & Message); + end Fixed_Conversion_Check; + + procedure Fixed_To_Short is + new Fixed_Conversion_Check( Duration, Unsigned_Edge_8 ); + + procedure Fixed_To_Eight is + new Fixed_Conversion_Check( Duration, Unsigned_8_Bit ); + + procedure Fixed_To_Wide is + new Fixed_Conversion_Check( Duration, Unsigned_Over_8 ); + + function Identity( A_Stitch: Duration ) return Duration is + Threadbare : constant Duration := 0.0; + begin + if Report.Ident_Bool( A_Stitch = Threadbare ) then + return Threadbare; + else + return A_Stitch; + end if; + end Identity; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +begin -- Main test procedure. + + Report.Test ("C460008", "Check that conversion to " & + "a modular type raises Constraint_Error when " & + "the operand value is outside the base range " & + "of the modular type" ); + + + -- Integer Error cases + + Int_To_Short( Report.Ident_Int( -1 ), "I2S Dynamic, Negative" ); + Int_To_Short( Report.Ident_Int( Shy_By_One ), "I2S Dynamic, At_Mod" ); + Int_To_Short( Report.Ident_Int( Heavy_By_Two+1 ), "I2S Dynamic, Over_Mod" ); + + Int_To_Eight( -Shy_By_One, "I28 Static, Negative" ); + Int_To_Eight( 2**8, "I28 Static, At_Mod" ); + Int_To_Eight( Heavy_By_Two+1, "I28 Static, Over_Mod" ); + + Int_To_Wide ( Report.Ident_Int( -(Heavy_By_Two*2) ), + "I2W Dynamic, Negative" ); + Int_To_Wide ( Heavy_By_Two, "I2W Static, At_Mod" ); + Int_To_Wide ( Report.Ident_Int( Heavy_By_Two*2 ), "I2W Dynamic, Over_Mod" ); + + -- Float Error cases + + Float_To_Short( -13.31, "F2S Static, Negative" ); + Float_To_Short( Identity ( Float(Shy_By_One)), "F2S Dynamic, At_Mod" ); + Float_To_Short( 6378.388, "F2S Static, Over_Mod" ); + + Float_To_Eight( Identity( -99.3574 ), "F28 Dynamic, Negative" ); + Float_To_Eight( 2.0**8, "F28 Static, At_Mod" ); + Float_To_Eight( 2.0**9, "F28 Static, Over_Mod" ); + + Float_To_Wide ( -0.54953_93129_81644, "FTW Static, Negative" ); + Float_To_Wide ( Identity( 2.0**8 +2.0 ), "FTW Dynamic, At_Mod" ); + Float_To_Wide ( Identity( 2.0**8 +2.5001 ), "FTW Dynamic, Over_Mod" ); + Float_To_Wide ( Identity( Float'Last ), "FTW Dynamic, Over_Mod" ); + + -- Fixed Error cases + + Fixed_To_Short( Identity( -5.00 ), "D2S Dynamic, Negative" ); + Fixed_To_Short( Shy_By_One * 1.0, "D2S Static, At_Mod" ); + Fixed_To_Short( 1995.9, "D2S Static, Over_Mod" ); + + Fixed_To_Eight( -0.5, "D28 Static, Negative" ); + Fixed_To_Eight( 2.0*128, "D28 Static, At_Mod" ); + Fixed_To_Eight( Identity( 2001.2 ), "D28 Dynamic, Over_Mod" ); + + Fixed_To_Wide ( Duration'First, "D2W Static, Negative" ); + Fixed_To_Wide ( Identity( 2*128.0 +2.0 ), "D2W Dynamic, At_Mod" ); + Fixed_To_Wide ( Duration'Last, "D2W Static, Over_Mod" ); + + -- having made it this far, the rest is downhill... + -- check a few, correct, edge cases, and we're done + + Eye_Dew: declare + A_Float : Float := 0.0; + Your_Time : Duration := 0.0; + Number : Integer := 0; + + Little : Unsigned_Edge_8; + Moderate : Unsigned_8_Bit; + Big : Unsigned_Over_8; + + begin + Little := Unsigned_Edge_8(A_Float); + Assert( Little = 0, "Float => Little, 0"); + + + Moderate := Unsigned_8_Bit (Your_Time); + Assert( Moderate = 0, "Your_Time => Moderate, 0"); + + Big := Unsigned_Over_8 (Number); + Assert( Big = 0, "Number => Big, 0"); + + A_Float := 2.0**8-2.0; + Your_Time := 2.0*128-2.0; + Number := 2**8; + + Little := Unsigned_Edge_8(A_Float); + Assert( Little = 254, "Float => Little, 254"); + + Little := Unsigned_Edge_8(Your_Time); + Assert( Little = 254, "Your_Time => Little, 254"); + + Big := Unsigned_Over_8 (A_Float + 2.0); + Assert( Big = 256, "Sense => Big, 256"); + + Big := Unsigned_Over_8 (Number); + Assert( Big = 256, "Number => Big, 256"); + + end Eye_Dew; + + Report.Result; + +end C460008; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460009.a b/gcc/testsuite/ada/acats/tests/c4/c460009.a new file mode 100644 index 000000000..62dbd47c2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460009.a @@ -0,0 +1,467 @@ +-- C460009.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 Constraint_Error is raised in cases of null arrays when: +-- 1. an assignment is made to a null array if the length of each +-- dimension of the operand does not match the length of +-- the corresponding dimension of the target subtype. +-- 2. an array actual parameter does not match the length of +-- corresponding dimensions of the formal in out parameter where +-- the actual parameter has the form of a type conversion. +-- 3. an array actual parameter does not match the length of +-- corresponding dimensions of the formal out parameter where +-- the actual parameter has the form of a type conversion. +-- +-- TEST DESCRIPTION: +-- This transition test creates examples where array of null ranges +-- raises Constraint_Error if any of the lengths mismatch. +-- +-- Inspired by C52103S.ADA, C64105E.ADA, and C64105F.ADA. +-- +-- +-- CHANGE HISTORY: +-- 21 Mar 96 SAIC Initial version for ACVC 2.1. +-- 21 Sep 96 SAIC ACVC 2.1: Added new case. +-- +--! + +with Report; + +procedure C460009 is + + subtype Int is Integer range 1 .. 3; + +begin + + Report.Test("C460009","Check that Constraint_Error is raised in " & + "cases of null arrays if any of the lengths mismatch " & + "in assignments and parameter passing"); + + --------------------------------------------------------------------------- + declare + + type Arr_Int1 is array (Int range <>) of Integer; + Arr_Obj1 : Arr_Int1 (2 .. Report.Ident_Int(1)); -- null array object + + begin + + -- Same lengths, no Constraint_Error raised. + Arr_Obj1 := (Report.Ident_Int(3) .. 2 => Report.Ident_Int(1)); + + Report.Comment ("Dead assignment prevention in Arr_Obj1 => " & + Integer'Image (Arr_Obj1'Last)); + + exception + + when Constraint_Error => + Report.Failed ("Arr_Obj1 - Constraint_Error exception raised"); + when others => + Report.Failed ("Arr_Obj1 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Arr_Int2 is array (Int range <>, Int range <>) of Integer; + Arr_Obj2 : Arr_Int2 (1 .. Report.Ident_Int(2), + Report.Ident_Int(3) .. Report.Ident_Int(2)); + -- null array object + begin + + -- Same lengths, no Constraint_Error raised. + Arr_Obj2 := Arr_Int2'(Report.Ident_Int(2) .. 3 => + (Report.Ident_Int(2) .. Report.Ident_Int(1) => + Report.Ident_Int(1))); + + Report.Comment ("Dead assignment prevention in Arr_Obj2 => " & + Integer'Image (Arr_Obj2'Last)); + + exception + + when Constraint_Error => + Report.Failed ("Arr_Obj2 - Constraint_Error exception raised"); + when others => + Report.Failed ("Arr_Obj2 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Arr_Int3 is array (Int range <>, Int range <>) of Integer; + Arr_Obj3 : Arr_Int3 (1 .. Report.Ident_Int(2), + Report.Ident_Int(3) .. Report.Ident_Int(2)); + -- null array object + + begin + + -- Lengths mismatch, Constraint_Error raised. + Arr_Obj3 := Arr_Int3'(Report.Ident_Int(3) .. 2 => + (Report.Ident_Int(1) .. Report.Ident_Int(3) => + Report.Ident_Int(1))); + + Report.Comment ("Dead assignment prevention in Arr_Obj3 => " & + Integer'Image (Arr_Obj3'Last)); + + Report.Failed ("Constraint_Error not raised in Arr_Obj3"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Arr_Obj3 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Arr_Int4 is array (Int range <>, Int range <>, Int range <>) of + Integer; + Arr_Obj4 : Arr_Int4 (1 .. Report.Ident_Int(2), + Report.Ident_Int(1) .. Report.Ident_Int(3), + Report.Ident_Int(3) .. Report.Ident_Int(2)); + -- null array object + begin + + -- Lengths mismatch, Constraint_Error raised. + Arr_Obj4 := Arr_Int4'(Report.Ident_Int(1) .. 3 => + (Report.Ident_Int(1) .. Report.Ident_Int(2) => + (Report.Ident_Int(3) .. Report.Ident_Int(2) => + Report.Ident_Int(1)))); + + Report.Comment ("Dead assignment prevention in Arr_Obj4 => " & + Integer'Image (Arr_Obj4'Last)); + + Report.Failed ("Constraint_Error not raised in Arr_Obj4"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Arr_Obj4 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Arr_Int5 is array (Int range <>) of Integer; + Arr_Obj5 : Arr_Int5 (2 .. Report.Ident_Int(1)); -- null array object + + begin + + -- Only lengths of two null ranges are different, no Constraint_Error + -- raised. + Arr_Obj5 := (Report.Ident_Int(3) .. 1 => Report.Ident_Int(1)); + + Report.Comment ("Dead assignment prevention in Arr_Obj5 => " & + Integer'Image (Arr_Obj5'Last)); + + exception + + when Constraint_Error => + Report.Failed ("Arr_Obj5 - Constraint_Error exception raised"); + when others => + Report.Failed ("Arr_Obj5 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + subtype Str is String (Report.Ident_Int(5) .. 4); + -- null string + Str_Obj : Str; + + begin + + -- Same lengths, no Constraint_Error raised. + Str_Obj := (Report.Ident_Int(1) .. 0 => 'Z'); + Str_Obj(2 .. 1) := ""; + Str_Obj(4 .. 2) := (others => 'X'); + Str_Obj(Report.Ident_Int(6) .. 3) := ""; + Str_Obj(Report.Ident_Int(0) .. Report.Ident_Int(-1)) := (others => 'Y'); + + exception + + when Constraint_Error => + Report.Failed ("Str_Obj - Constraint_Error exception raised"); + when others => + Report.Failed ("Str_Obj - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Arr_Char5 is array (Int range <>, Int range <>) of Character; + subtype Formal is Arr_Char5 + (Report.Ident_Int(2) .. 0, 1 .. Report.Ident_Int(3)); + Arr_Obj5 : Arr_Char5 (Report.Ident_Int(2) .. Report.Ident_Int(1), + Report.Ident_Int(1) .. Report.Ident_Int(2)) + := (Report.Ident_Int(2) .. Report.Ident_Int(1) => + (Report.Ident_Int(1) .. Report.Ident_Int(2) => ' ')); + + procedure Proc5 (P : in out Formal) is + begin + Report.Failed ("No exception raised in Proc5"); + + exception + + when Constraint_Error => + Report.Failed ("Constraint_Error exception raised in Proc5"); + when others => + Report.Failed ("Others exception raised in Proc5"); + end; + + begin + + -- Lengths mismatch in the type conversion, Constraint_Error raised. + Proc5 (Formal(Arr_Obj5)); + + Report.Failed ("Constraint_Error not raised in the call Proc5"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Arr_Obj5 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Formal is array + (Report.Ident_Int(1) .. 3, 3 .. Report.Ident_Int(1)) of Character; + + type Actual is array + (Report.Ident_Int(5) .. 3, 3 .. Report.Ident_Int(5)) of Character; + + Arr_Obj6 : Actual := (5 .. 3 => (3 .. 5 => ' ')); + + procedure Proc6 (P : in out Formal) is + begin + Report.Failed ("No exception raised in Proc6"); + + exception + + when Constraint_Error => + Report.Failed ("Constraint_Error exception raised in Proc6"); + when others => + Report.Failed ("Others exception raised in Proc6"); + end; + + begin + + -- Lengths mismatch in the type conversion, Constraint_Error raised. + Proc6 (Formal(Arr_Obj6)); + + Report.Failed ("Constraint_Error not raised in the call Proc6"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Arr_Obj6 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Formal is array (Int range <>, Int range <>) of Character; + type Actual is array (Positive range 5 .. 2, + Positive range 1 .. 3) of Character; + + Arr_Obj7 : Actual := (5 .. 2 => (1 .. 3 => ' ')); + + procedure Proc7 (P : in out Formal) is + begin + if P'Last /= 2 and P'Last(2) /= 3 then + Report.Failed ("Wrong bounds passed for Arr_Obj7"); + end if; + + -- Lengths mismatch, Constraint_Error raised. + P := (1 .. 3 => (3 .. 0 => ' ')); + + Report.Comment ("Dead assignment prevention in Proc7 => " & + Integer'Image (P'Last)); + + Report.Failed ("No exception raised in Proc7"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Others exception raised in Proc7"); + end; + + begin + + -- Same lengths, no Constraint_Error raised. + Proc7 (Formal(Arr_Obj7)); + + if Arr_Obj7'Last /= 2 and Arr_Obj7'Last(2) /= 3 then + Report.Failed ("Bounds changed for Arr_Obj7"); + end if; + + exception + + when Constraint_Error => + Report.Failed ("Constraint_Error exception raised after call Proc7"); + when others => + Report.Failed ("Arr_Obj7 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Arr_Char8 is array (Int range <>, Int range <>) of Character; + subtype Formal is Arr_Char8 + (Report.Ident_Int(2) .. 0, 1 .. Report.Ident_Int(3)); + Arr_Obj8 : Arr_Char8 (Report.Ident_Int(2) .. Report.Ident_Int(1), + Report.Ident_Int(1) .. Report.Ident_Int(2)); + + procedure Proc8 (P : out Formal) is + begin + Report.Failed ("No exception raised in Proc8"); + + exception + + when Constraint_Error => + Report.Failed ("Constraint_Error exception raised in Proc8"); + when others => + Report.Failed ("Others exception raised in Proc8"); + end; + + begin + + -- Lengths mismatch in the type conversion, Constraint_Error raised. + Proc8 (Formal(Arr_Obj8)); + + Report.Failed ("Constraint_Error not raised in the call Proc8"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Arr_Obj8 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Formal is array + (Report.Ident_Int(1) .. 3, 3 .. Report.Ident_Int(1)) of Character; + + type Actual is array + (Report.Ident_Int(5) .. 3, 3 .. Report.Ident_Int(5)) of Character; + + Arr_Obj9 : Actual; + + procedure Proc9 (P : out Formal) is + begin + Report.Failed ("No exception raised in Proc9"); + + exception + + when Constraint_Error => + Report.Failed ("Constraint_Error exception raised in Proc9"); + when others => + Report.Failed ("Others exception raised in Proc9"); + end; + + begin + + -- Lengths mismatch in the type conversion, Constraint_Error raised. + Proc9 (Formal(Arr_Obj9)); + + Report.Failed ("Constraint_Error not raised in the call Proc9"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Arr_Obj9 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Formal is array (Int range <>, Int range <>) of Character; + type Actual is array (Positive range 5 .. 2, + Positive range 1 .. 3) of Character; + + Arr_Obj10 : Actual; + + procedure Proc10 (P : out Formal) is + begin + if P'Last /= 2 and P'Last(2) /= 3 then + Report.Failed ("Wrong bounds passed for Arr_Obj10"); + end if; + + -- Lengths mismatch, Constraint_Error raised. + P := (1 .. 3 => (3 .. 1 => ' ')); + + Report.Comment ("Dead assignment prevention in Proc10 => " & + Integer'Image (P'Last)); + + Report.Failed ("No exception raised in Proc10"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Others exception raised in Proc10"); + end; + + begin + + -- Same lengths, no Constraint_Error raised. + Proc10 (Formal(Arr_Obj10)); + + if Arr_Obj10'Last /= 2 and Arr_Obj10'Last(2) /= 3 then + Report.Failed ("Bounds changed for Arr_Obj10"); + end if; + + exception + + when Constraint_Error => + Report.Failed ("Constraint_Error exception raised after call Proc10"); + when others => + Report.Failed ("Arr_Obj10 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + Report.Result; + +end C460009; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460010.a b/gcc/testsuite/ada/acats/tests/c4/c460010.a new file mode 100644 index 000000000..790a8c339 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460010.a @@ -0,0 +1,354 @@ +-- C460010.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 an array aggregate without an others choice assigned +-- to an object of a constrained array subtype, Constraint_Error is not +-- raised if the length of each dimension of the aggregate equals the +-- length of the corresponding dimension of the target object, even if +-- the bounds of the corresponding index ranges do not match. +-- +-- TEST DESCRIPTION: +-- The test verifies that sliding of array bounds is performed on array +-- aggregates that are part of a larger aggregate, where the bounds of +-- the corresponding index ranges do not match but the lengths of the +-- corresponding dimensions are the same. Both aggregates containing +-- named associations and positional associations are checked. Cases +-- involving static and nonstatic index constraints, as well as pre- +-- defined and modular integer index subtypes, are included. +-- +-- +-- CHANGE HISTORY: +-- 15 Apr 96 SAIC Prerelease version for ACVC 2.1. +-- 20 Oct 96 SAIC Removed unnecessary parentheses and type +-- conversions. +-- +--! + +with Report; +pragma Elaborate (Report); + +package C460010_0 is + + type Modular_Type is mod 10; -- Range 0 .. 9. + + + Two : Modular_Type := Modular_Type (Report.Ident_Int(2)); + Four : Modular_Type := Modular_Type (Report.Ident_Int(4)); + + type Array_Modular_Index is array (Modular_Type range <>) of Integer; + + subtype Array_Static_Modular_Constraint is Array_Modular_Index(2..4); + subtype Array_Nonstatic_Modular_Constraint is Array_Modular_Index(Two..Four); + +end C460010_0; + + + --==================================================================-- + + +with Report; +pragma Elaborate (Report); + +package C460010_1 is + + One : Integer := Report.Ident_Int(1); + Ten : Integer := Report.Ident_Int(10); + + subtype Integer_Subtype is Integer range One .. Ten; + + + Two : Integer := Report.Ident_Int(2); + Four : Integer := Report.Ident_Int(4); + + type Array_Integer_Index is array (Integer_Subtype range <>) of Boolean; + + subtype Array_Static_Integer_Constraint is Array_Integer_Index(2..4); + subtype Array_Nonstatic_Integer_Constraint is Array_Integer_Index(Two..Four); + +end C460010_1; + + + --==================================================================-- + + +-- Generic equality function: + +generic + type Operand_Type is private; +function C460010_2 (L, R : Operand_Type) return Boolean; + + +function C460010_2 (L, R : Operand_Type) return Boolean is +begin + return L = R; +end C460010_2; + + + --==================================================================-- + + +with C460010_0; +with C460010_1; +with C460010_2; + +with Report; + +procedure C460010 is + + generic function Generic_Equality renames C460010_2; + +begin + Report.Test ("C460010", "Check that Constraint_Error is not raised if " & + "an array aggregate without an others choice is assigned " & + "to an object of a constrained array subtype, and the " & + "length of each dimension of the aggregate equals the " & + "length of the corresponding dimension of the target object"); + + + ---=---=---=---=---=---=---=---=---=---=--- + + + declare + type Arr is array (1..1) of C460010_0.Array_Static_Modular_Constraint; + function Equals is new Generic_Equality (Arr); + Target : Arr; + begin + ---=---=---=---=---=---=--- + CASE_1: + begin + Target := (1 => (1 => 1, 2 => 2, 3 => 3)); -- Named associations. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 1"); + when others => + Report.Failed ("Unexpected exception raised: Case 1"); + end CASE_1; + + ---=---=---=---=---=---=--- + + CASE_2: + begin + Target := (1 => (5, 10, 15)); -- Positional associations. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 2"); + when others => + Report.Failed ("Unexpected exception raised: Case 2"); + end CASE_2; + + ---=---=---=---=---=---=--- + end; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + declare + type Rec (Disc : C460010_0.Modular_Type := 4) is record + Arr : C460010_0.Array_Modular_Index(2 .. Disc); + end record; + + function Equals is new Generic_Equality (Rec); + Target : Rec; + begin + ---=---=---=---=---=---=--- + CASE_3: + begin + Target := (Disc => 4, Arr => (1 => 1, 2 => 2, 3 => 3)); -- Named. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 3"); + when others => + Report.Failed ("Unexpected exception raised: Case 3"); + end CASE_3; + + ---=---=---=---=---=---=--- + + CASE_4: + begin + Target := (Disc => 4, Arr => (1 ,2, 3)); -- Positional. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 4"); + when others => + Report.Failed ("Unexpected exception raised: Case 4"); + end CASE_4; + + ---=---=---=---=---=---=--- + end; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + declare + type Arr is array (1..1) of C460010_0.Array_Nonstatic_Modular_Constraint; + function Equals is new Generic_Equality (Arr); + Target : Arr; + begin + ---=---=---=---=---=---=--- + CASE_5: + begin + Target := (1 => (1 => 1, 2 => 2, 3 => 3)); -- Named associations. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 5"); + when others => + Report.Failed ("Unexpected exception raised: Case 5"); + end CASE_5; + + ---=---=---=---=---=---=--- + + CASE_6: + begin + Target := (1 => ((5, 10, 15))); -- Positional associations. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 6"); + when others => + Report.Failed ("Unexpected exception raised: Case 6"); + end CASE_6; + + ---=---=---=---=---=---=--- + end; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + declare + type Arr is array (1..1) of C460010_1.Array_Static_Integer_Constraint; + function Equals is new Generic_Equality (Arr); + Target : Arr; + begin + ---=---=---=---=---=---=--- + CASE_7: + begin + Target := (1 => (1 => True, 2 => True, 3 => False)); -- Named. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 7"); + when others => + Report.Failed ("Unexpected exception raised: Case 7"); + end CASE_7; + + ---=---=---=---=---=---=--- + + CASE_8: + begin + Target := (1 => ((False, False, True))); -- Positional. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 8"); + when others => + Report.Failed ("Unexpected exception raised: Case 8"); + end CASE_8; + + ---=---=---=---=---=---=--- + end; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + declare + type Arr is array (1..1) of C460010_1.Array_Nonstatic_Integer_Constraint; + function Equals is new Generic_Equality (Arr); + Target : Arr; + begin + ---=---=---=---=---=---=--- + CASE_9: + begin + Target := (1 => (1 => True, 2 => True, 3 => False)); -- Named. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 9"); + when others => + Report.Failed ("Unexpected exception raised: Case 9"); + end CASE_9; + + ---=---=---=---=---=---=--- + + CASE_10: + begin + Target := (1 => (False, False, True)); -- Positional. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 10"); + when others => + Report.Failed ("Unexpected exception raised: Case 10"); + end CASE_10; + + ---=---=---=---=---=---=--- + end; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + Report.Result; + +end C460010; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460011.a b/gcc/testsuite/ada/acats/tests/c4/c460011.a new file mode 100644 index 000000000..56e4c0c4e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460011.a @@ -0,0 +1,210 @@ +-- C460011.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and +-- F08630-91-C-0015, 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 conversion of a decimal type to a modular type raises +-- Constraint_Error when the operand value is outside the base range +-- of the modular type. +-- Check that a conversion of a decimal type to an integer type +-- rounds correctly. +-- +-- TEST DESCRIPTION: +-- Test conversion from decimal types to modular types. Test +-- conversion to mod 255, mod 256 and mod 258 to test the boundaries +-- of 8 bit (+/-) unsigned numbers. +-- Test operand values that are negative, the value of the mod, +-- and greater than the value of the mod. +-- Declare a generic test procedure and instantiate it for each of the +-- unsigned types for each operand type. +-- Check that the the operand is properly rounded during the conversion. +-- +-- APPLICABILITY CRITERIA: +-- This test is applicable to all implementations which support +-- decimal types. +-- +-- CHANGE HISTORY: +-- 24 NOV 98 RLB Split decimal cases from C460008 into this +-- test, added conversions to integer types. +-- 18 JAN 99 RLB Repaired errors in test. +-- +--! + +------------------------------------------------------------------- C460011 + +with Report; + +procedure C460011 is + + Shy_By_One : constant := 2**8-1; + Heavy_By_Two : constant := 2**8+2; + + type Unsigned_Edge_8 is mod Shy_By_One; + type Unsigned_8_Bit is mod 2**8; + type Unsigned_Over_8 is mod Heavy_By_Two; + + type Signed_8_Bit is range -128 .. 127; + type Signed_Over_8 is range -200 .. 200; + + NPC : constant String := " not properly converted"; + + procedure Assert( Truth: Boolean; Message: String ) is + begin + if not Truth then + Report.Failed(Message); + end if; + end Assert; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + type Decim is delta 0.1 digits 5; -- N/A => ERROR. + + generic + type Source is delta <> digits <>; + type Target is mod <>; + procedure Decimal_Conversion_Check( For_The_Value : Source; + Message : String ); + + procedure Decimal_Conversion_Check( For_The_Value : Source; + Message : String ) is + + Item : Target; + + begin + Item := Target( For_The_Value ); + Report.Failed("Deci expected Constraint_Error " & Message); + Report.Comment("Value of" & Target'Image(Item) & NPC); + exception + when Constraint_Error => null; -- expected case + when others => Report.Failed("Deci raised wrong exception " & Message); + end Decimal_Conversion_Check; + + procedure Decim_To_Short is + new Decimal_Conversion_Check( Decim, Unsigned_Edge_8 ); + + procedure Decim_To_Eight is + new Decimal_Conversion_Check( Decim, Unsigned_8_Bit ); + + procedure Decim_To_Wide is + new Decimal_Conversion_Check( Decim, Unsigned_Over_8 ); + + function Identity( Launder: Decim ) return Decim is + Flat_Broke : constant Decim := 0.0; + begin + if Report.Ident_Bool( Launder = Flat_Broke ) then + return Flat_Broke; + else + return Launder; + end if; + end Identity; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +begin -- Main test procedure. + + Report.Test ("C460011", "Check that conversion to " & + "a modular type raises Constraint_Error when " & + "the operand value is outside the base range " & + "of the modular type" ); + + -- Decimal Error cases + + Decim_To_Short( Identity( -5.00 ), "M2S Dynamic, Negative" ); + Decim_To_Short( Shy_By_One * 1.0, "M2S Static, At_Mod" ); + Decim_To_Short( 1995.9, "M2S Static, Over_Mod" ); + + Decim_To_Eight( -0.5, "M28 Static, Negative" ); + Decim_To_Eight( 2.0*128, "M28 Static, At_Mod" ); + Decim_To_Eight( Identity( 2001.2 ), "M28 Dynamic, Over_Mod" ); + + Decim_To_Wide ( Decim'First, "M2W Static, Negative" ); + Decim_To_Wide ( Identity( 2*128.0 +2.0 ), "M2W Dynamic, At_Mod" ); + Decim_To_Wide ( Decim'Last, "M2W Static, Over_Mod" ); + + -- Check a few, correct, edge cases, for modular types. + + Eye_Dew: declare + Sense : Decim := 0.00; + + Little : Unsigned_Edge_8; + Moderate : Unsigned_8_Bit; + Big : Unsigned_Over_8; + + begin + Moderate := Unsigned_8_Bit (Sense); + Assert( Moderate = 0, "Sense => Moderate, 0"); + + Sense := 2*128.0; + + Big := Unsigned_Over_8 (Sense); + Assert( Big = 256, "Sense => Big, 256"); + + end Eye_Dew; + + Rounding: declare + Easy : Decim := Identity ( 2.0); + Simple : Decim := Identity ( 2.1); + Halfway : Decim := Identity ( 2.5); + Upward : Decim := Identity ( 2.8); + Chop : Decim := Identity (-2.2); + Neg_Half : Decim := Identity (-2.5); + Downward : Decim := Identity (-2.7); + + Little : Unsigned_Edge_8; + Moderate : Unsigned_8_Bit; + Big : Unsigned_Over_8; + + Also_Little:Signed_8_Bit; + Also_Big : Signed_Over_8; + + begin + Little := Unsigned_Edge_8 (Easy); + Assert( Little = 2, "Easy => Little, 2"); + + Moderate := Unsigned_8_Bit (Simple); + Assert( Moderate = 2, "Simple => Moderate, 2"); + + Big := Unsigned_Over_8 (Halfway); -- Rounds up by 4.6(33). + Assert( Big = 3, "Halfway => Big, 3"); + + Little := Unsigned_Edge_8 (Upward); + Assert( Little = 3, "Upward => Little, 3"); + + Also_Big := Signed_Over_8 (Halfway); -- Rounds up by 4.6(33). + Assert( Also_Big = 3, "Halfway => Also_Big, 3"); + + Also_Little := Signed_8_Bit (Chop); + Assert( Also_Little = -2, "Chop => Also_Little, -2"); + + Also_Big := Signed_Over_8 (Neg_Half); -- Rounds down by 4.6(33). + Assert( Also_Big = -3, "Halfway => Also_Big, -3"); + + Also_Little := Signed_8_Bit (Downward); + Assert( Also_Little = -3, "Downward => Also_Little, -3"); + + end Rounding; + + + Report.Result; + +end C460011; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460012.a b/gcc/testsuite/ada/acats/tests/c4/c460012.a new file mode 100644 index 000000000..0fb32060a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460012.a @@ -0,0 +1,93 @@ +-- C460012.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 the view created by a view conversion is constrained if the +-- target subtype is indefinite. (Defect Report 8652/0017, Technical +-- Corrigendum 4.6(54/1)). +-- +-- CHANGE HISTORY: +-- 25 JAN 2001 PHL Initial version. +-- 29 JUN 2001 RLB Reformatted for ACATS. Added optimization blocking. +-- 02 JUL 2001 RLB Fixed discriminant reference. +-- +--! +with Ada.Exceptions; +use Ada.Exceptions; +with Report; +use Report; +procedure C460012 is + + subtype Index is Positive range 1 .. 10; + + type Definite_Parent (D1 : Index := 6) is + record + F : String (1 .. D1) := (others => 'a'); + end record; + + type Indefinite_Child (D2 : Index) is new Definite_Parent (D1 => D2); + + Y : Definite_Parent; + + procedure P (X : in out Indefinite_Child) is + C : Character renames X.F (3); + begin + X := (1, "a"); + if C /= 'a' then + Failed ("No exception raised when changing the " & + "discriminant of a view conversion, value of C changed"); + elsif X.D2 /= 1 then + Failed ("No exception raised when changing the " & + "discriminant of a view conversion, discriminant not " & + "changed"); + -- This check primarily exists to prevent X from being optimized by + -- 11.6 permissions, or the Failed call being made before the assignment. + else + Failed ("No exception raised when changing the " & + "discriminant of a view conversion, discriminant changed"); + end if; + exception + when Constraint_Error => + null; + when E: others => + Failed ("Wrong exception " & Exception_Name (E) & " raised - " & + Exception_Message (E)); + end P; + +begin + Test ("C460012", + "Check that the view created by a view conversion " & + "is constrained if the target subtype is indefinite"); + + P (Indefinite_Child (Y)); + + if Y.D1 /= Ident_Int(6) then + Failed ("Discriminant of indefinite view changed"); + -- This check exists mainly to prevent Y from being optimized away. + end if; + + Result; +end C460012; + diff --git a/gcc/testsuite/ada/acats/tests/c4/c46011a.ada b/gcc/testsuite/ada/acats/tests/c4/c46011a.ada new file mode 100644 index 000000000..16a1df6c7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46011a.ada @@ -0,0 +1,145 @@ +-- C46011A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT INTEGER CONVERSIONS ARE PERFORMED CORRECTLY WHEN THE +-- TARGET AND OPERAND TYPES ARE BOTH INTEGER TYPES. + +-- R.WILLIAMS 9/8/86 + +WITH REPORT; USE REPORT; +PROCEDURE C46011A IS + + TYPE INT1 IS RANGE -100 .. 100; + I1 : INT1 := INT1'VAL (IDENT_INT (10)); + F1 : INT1 := INT1'VAL (IDENT_INT (-100)); + L1 : INT1 := INT1'VAL (IDENT_INT (100)); + + TYPE INT2 IS RANGE -100 .. 100; + I2 : INT2 := INT2'VAL (IDENT_INT (10)); + F2 : INT2 := INT2'VAL (IDENT_INT (-100)); + L2 : INT2 := INT2'VAL (IDENT_INT (100)); + + + TYPE NEWINTEGER IS NEW INTEGER; + N1 : NEWINTEGER := + NEWINTEGER'VAL (IDENT_INT (10)); + + T1 : INTEGER := IDENT_INT (10); + + U1 : CONSTANT := INTEGER'POS (10); +BEGIN + TEST ( "C46011A", "CHECK THAT INTEGER CONVERSIONS ARE " & + "PERFORMED CORRECTLY WHEN THE TARGET AND " & + "OPERAND TYPES ARE BOTH INTEGER TYPES" ); + + IF INT1 (U1) /= U1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (U1)'" ); + END IF; + + IF INT1 (I1) /= I1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (I1)'" ); + END IF; + + IF INT1 (N1) /= I1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (N1)'" ); + END IF; + + IF INT1 (10) /= I1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (10)'" ); + END IF; + + IF INT1 (T1) /= I1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (T1)'" ); + END IF; + + IF INT1 (F2) /= F1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (F2)'" ); + END IF; + + IF INT1 (L2) /= L1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (L2)'" ); + END IF; + + IF INT2 (I1) /= I2 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT2 (I1)'" ); + END IF; + + IF INT2 (T1) /= 10 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT2 (T1)'" ); + END IF; + + IF INT2 (F1) /= -100 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT2 (F1)'" ); + END IF; + + IF INT2 (L1) /= 100 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT2 (L1)'" ); + END IF; + + IF NEWINTEGER (I1) /= N1 THEN + FAILED ( "INCORRECT CONVERSION OF 'NEWINTEGER (I1)'" ); + END IF; + + IF NEWINTEGER (N1) /= N1 THEN + FAILED ( "INCORRECT CONVERSION OF 'NEWINTEGER (N1)'" ); + END IF; + + IF NEWINTEGER (T1) /= N1 THEN + FAILED ( "INCORRECT CONVERSION OF 'NEWINTEGER (T1)'" ); + END IF; + + IF NEWINTEGER (INTEGER (N1)) /= N1 THEN + FAILED ( "INCORRECT CONVERSION OF " & + "'NEWINTEGER (INTEGER (N1))'" ); + END IF; + + IF NEWINTEGER (INTEGER (N1 + 1)) /= 11 THEN + FAILED ( "INCORRECT CONVERSION OF " & + "'NEWINTEGER (INTEGER (N1 + 1))'" ); + END IF; + + IF INTEGER (10) /= T1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INTEGER (10)'" ); + END IF; + + IF INTEGER (N1) /= 10 THEN + FAILED ( "INCORRECT CONVERSION OF 'INTEGER (N1)'" ); + END IF; + + IF INTEGER (I1) /= T1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INTEGER (I1)'" ); + END IF; + + IF INTEGER (INT1 (NEWINTEGER (INT1 (I1)))) /= T1 THEN + FAILED ( "INCORRECT CONVERSION OF " & + "'INTEGER (INT1 (NEWINTEGER (INT1 (I1)))'" ); + END IF; + + + IF INTEGER (I1 + 1) /= 11 THEN + FAILED ( "INCORRECT CONVERSION OF 'INTEGER (I1 + 1)'" ); + END IF; + + RESULT; +END C46011A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46013a.ada b/gcc/testsuite/ada/acats/tests/c4/c46013a.ada new file mode 100644 index 000000000..b9fa7d069 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46013a.ada @@ -0,0 +1,260 @@ +-- C46013A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT INTEGER CONVERSIONS ARE PERFORMED CORRECTLY WHEN THE +-- OPERAND TYPE IS A FIXED POINT TYPE. + +-- HISTORY: +-- JET 02/09/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C46013A IS + + TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#; + TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#; + TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#; + TYPE FIX4 IS NEW FIX1; + + F1 : FIX1 := 7.75; + F2 : FIX2 := -111.25; + F3 : FIX3 := 0.875; + F4 : FIX4 := -15.25; + + TYPE INT IS RANGE -512 .. 512; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + RETURN I * INT(IDENT_INT(1)); + END IDENT; + +BEGIN + TEST ("C46013A", "CHECK THAT INTEGER CONVERSIONS ARE PERFORMED " & + "CORRECTLY WHEN THE OPERAND TYPE IS A FIXED " & + "POINT TYPE"); + + IF INTEGER(FIX1'(-7.25)) /= IDENT_INT(-7) THEN + FAILED ("INCORRECT VALUE (1)"); + END IF; + + IF INTEGER(FIX1'(6.75)) /= IDENT_INT(7) THEN + FAILED ("INCORRECT VALUE (2)"); + END IF; + + IF INTEGER(F1) /= IDENT_INT(8) THEN + FAILED ("INCORRECT VALUE (3)"); + END IF; + + IF INT(FIX1'(-7.25)) /= IDENT(-7) THEN + FAILED ("INCORRECT VALUE (4)"); + END IF; + + IF INTEGER(FIX1'(3.33)) /= IDENT_INT(3) AND + INTEGER(FIX1'(3.33)) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE (5)"); + END IF; + + IF INTEGER(FIX1'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX1'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX1'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX1'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX1 HALF VALUES ROUND UP"); + ELSIF INTEGER(FIX1'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX1'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX1'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX1'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX1 HALF VALUES ROUND DOWN"); + ELSIF INTEGER(FIX1'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX1'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX1'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX1'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX1 HALF VALUES ROUND TO EVEN"); + ELSIF INTEGER(FIX1'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX1'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX1'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX1'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX1 HALF VALUES ROUND TOWARD ZERO"); + ELSIF INTEGER(FIX1'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX1'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX1'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX1'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX1 HALF VALUES ROUND AWAY FROM ZERO"); + ELSE + COMMENT ("FIX1 HALF VALUES ROUND ERRATICALLY"); + END IF; + + IF INTEGER(FIX2'(-127.9375)) /= IDENT_INT(-128) THEN + FAILED ("INCORRECT VALUE (6)"); + END IF; + + IF INTEGER(FIX2'(127.0625)) /= IDENT_INT(127) THEN + FAILED ("INCORRECT VALUE (7)"); + END IF; + + IF INTEGER(F2) /= IDENT_INT(-111) THEN + FAILED ("INCORRECT VALUE (8)"); + END IF; + + IF INT(FIX2'(-0.25)) /= IDENT(0) THEN + FAILED ("INCORRECT VALUE (9)"); + END IF; + + IF INTEGER(FIX2'(66.67)) /= IDENT_INT(67) AND + INTEGER(FIX2'(66.67)) /= IDENT_INT(66) THEN + FAILED ("INCORRECT VALUE (10)"); + END IF; + + IF INTEGER(FIX2'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX2'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX2'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX2'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX2 HALF VALUES ROUND UP"); + ELSIF INTEGER(FIX2'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX2'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX2'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX2'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX2 HALF VALUES ROUND DOWN"); + ELSIF INTEGER(FIX2'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX2'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX2'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX2'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX2 HALF VALUES ROUND TO EVEN"); + ELSIF INTEGER(FIX2'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX2'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX2'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX2'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX2 HALF VALUES ROUND TOWARD ZERO"); + ELSIF INTEGER(FIX2'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX2'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX2'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX2'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX2 HALF VALUES ROUND AWAY FROM ZERO"); + ELSE + COMMENT ("FIX2 HALF VALUES ROUND ERRATICALLY"); + END IF; + + IF INTEGER(FIX3'(-0.25)) /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE (11)"); + END IF; + + IF INTEGER(FIX3'(511.75)) /= IDENT_INT(512) THEN + FAILED ("INCORRECT VALUE (12)"); + END IF; + + IF INTEGER(F3) /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE (13)"); + END IF; + + IF INT(FIX3'(-7.0)) /= IDENT(-7) THEN + FAILED ("INCORRECT VALUE (14)"); + END IF; + + IF INTEGER(FIX3'(-66.67)) /= IDENT_INT(-67) AND + INTEGER(FIX3'(-66.67)) /= IDENT_INT(-66) THEN + FAILED ("INCORRECT VALUE (15)"); + END IF; + + IF INTEGER(FIX3'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX3'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX3'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX3'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX3 HALF VALUES ROUND UP"); + ELSIF INTEGER(FIX3'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX3'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX3'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX3'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX3 HALF VALUES ROUND DOWN"); + ELSIF INTEGER(FIX3'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX3'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX3'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX3'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX3 HALF VALUES ROUND TO EVEN"); + ELSIF INTEGER(FIX3'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX3'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX3'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX3'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX3 HALF VALUES ROUND TOWARD ZERO"); + ELSIF INTEGER(FIX3'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX3'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX3'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX3'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX3 HALF VALUES ROUND AWAY FROM ZERO"); + ELSE + COMMENT ("FIX3 HALF VALUES ROUND ERRATICALLY"); + END IF; + + IF INTEGER(FIX4'(-7.25)) /= IDENT_INT(-7) THEN + FAILED ("INCORRECT VALUE (16)"); + END IF; + + IF INTEGER(FIX4'(6.75)) /= IDENT_INT(7) THEN + FAILED ("INCORRECT VALUE (17)"); + END IF; + + IF INTEGER(F4) /= IDENT_INT(-15) THEN + FAILED ("INCORRECT VALUE (18)"); + END IF; + + IF INT(FIX4'(-31.75)) /= IDENT(-32) THEN + FAILED ("INCORRECT VALUE (19)"); + END IF; + + IF INTEGER(FIX4'(3.33)) /= IDENT_INT(3) AND + INTEGER(FIX4'(3.33)) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE (20)"); + END IF; + + IF INTEGER(FIX4'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX4'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX4'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX4'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX4 HALF VALUES ROUND UP"); + ELSIF INTEGER(FIX4'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX4'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX4'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX4'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX4 HALF VALUES ROUND DOWN"); + ELSIF INTEGER(FIX4'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX4'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX4'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX4'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX4 HALF VALUES ROUND TO EVEN"); + ELSIF INTEGER(FIX4'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX4'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX4'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX4'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX4 HALF VALUES ROUND TOWARD ZERO"); + ELSIF INTEGER(FIX4'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX4'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX4'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX4'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX4 HALF VALUES ROUND AWAY FROM ZERO"); + ELSE + COMMENT ("FIX4 HALF VALUES ROUND ERRATICALLY"); + END IF; + + RESULT; + +END C46013A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46014a.ada b/gcc/testsuite/ada/acats/tests/c4/c46014a.ada new file mode 100644 index 000000000..9f47479df --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46014a.ada @@ -0,0 +1,287 @@ +-- C46014A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR PREDEFINED TYPE INTEGER, CHECK THAT +-- CONSTRAINT_ERROR IS RAISED IF THE OPERAND VALUE OF A +-- CONVERSION LIES OUTSIDE OF THE RANGE OF THE TARGET TYPE'S BASE +-- TYPE. ALSO, CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE +-- OPERAND VALUE LIES OUTSIDE OF THE RANGE OF THE TARGET TYPE'S +-- SUBTYPE BUT WITHIN THE RANGE OF THE BASE TYPE. + +-- HISTORY: +-- RJW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/13/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION. +-- JET 12/30/87 ADDED MORE CODE TO PREVENT OPTIMIZATION. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY +-- JRL 12/08/96 Changed usages of System.Max_Int and System.Min_Int to +-- Integer'Base'Last and Integer'Base'First in first two +-- subtests. + +WITH REPORT; USE REPORT; +PROCEDURE C46014A IS + + SUBTYPE SMALL IS INTEGER RANGE -100 .. 100; + S1 : SMALL; + + TYPE INT IS RANGE -100 .. 100; + T1 : INT; + + TYPE NEWINTEGER IS NEW INTEGER; + N1 : NEWINTEGER; + + SUBTYPE SUBNEW IS NEWINTEGER RANGE -100 .. 100; + SN : SUBNEW; + + I1 : INTEGER; + P1 : POSITIVE; + L1 : NATURAL; + + FUNCTION IDENT (I : INTEGER) RETURN INT IS + BEGIN + RETURN INT'VAL (IDENT_INT (I)); + END IDENT; + + FUNCTION IDENT (I : NEWINTEGER) RETURN NEWINTEGER IS + BEGIN + RETURN NEWINTEGER'VAL (IDENT_INT (NEWINTEGER'POS (I))); + END IDENT; + +BEGIN + TEST ( "C46014A", "FOR PREDEFINED TYPE INTEGER, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED IF " & + "THE OPERAND VALUE OF A CONVERSION LIES " & + "OUTSIDE OF THE RANGE OF THE TARGET TYPE'S " & + "BASE TYPE. ALSO, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED IF THE OPERAND " & + "VALUE LIES OUTSIDE OF THE RANGE OF THE " & + "TARGET TYPE'S SUBTYPE BUT WITHIN THE " & + "RANGE OF THE BASE TYPE" ); + + BEGIN + I1 := Integer'Base'Last + Ident_Int(1); + Failed ("NO EXCEPTION RAISED FOR INTEGER'BASE'LAST + 1"); + IF EQUAL (I1, I1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + Comment ("CONSTRAINT_ERROR RAISED FOR INTEGER'BASE'LAST + 1"); + WHEN OTHERS => + Failed ("WRONG EXCEPTION RAISED FOR INTEGER'BASE'LAST + 1"); + END; + + BEGIN + I1 := Integer'Base'First - Ident_Int(1); + Failed ("NO EXCEPTION RAISED FOR INTEGER'BASE'FIRST - 1"); + IF EQUAL (I1, I1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + Comment ("CONSTRAINT_ERROR RAISED FOR INTEGER'BASE'FIRST - 1"); + WHEN OTHERS => + Failed ("WRONG EXCEPTION RAISED FOR INTEGER'BASE'FIRST - 1"); + END; + + BEGIN + I1 := INTEGER (IDENT_INT (INTEGER'FIRST) - 1); + FAILED ( "NO EXCEPTION RAISED FOR " & + "INTEGER (IDENT_INT (INTEGER'FIRST) - 1)" ); + IF EQUAL (I1, I1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED FOR " & + "INTEGER (IDENT_INT (INTEGER'FIRST - 1)" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "INTEGER (IDENT_INT (INTEGER'FIRST - 1)" ); + END; + + BEGIN + N1 := NEWINTEGER (IDENT_INT (INTEGER'LAST) + 1); + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWINTEGER (IDENT_INT (INTEGER'LAST) + 1)" ); + IF EQUAL (INTEGER (N1), INTEGER (N1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED FOR " & + "NEWINTEGER (IDENT_INT (INTEGER'LAST + 1)" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWINTEGER (IDENT_INT (INTEGER'LAST + 1)" ); + END; + + BEGIN + T1 := INT (INT'BASE'FIRST - IDENT (1)); + FAILED ( "NO EXCEPTION RAISED FOR " & + "INT (INT'BASE'FIRST - IDENT (1))" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED FOR " & + "INT (INT'BASE'FIRST - IDENT (1))" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "INT (INT'BASE'FIRST - IDENT (1))" ); + END; + + BEGIN + T1 := IDENT (-101); + FAILED ( "NO EXCEPTION RAISED FOR " & + "T1 := -101" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "T1 := -101" ); + END; + + BEGIN + T1 := INTEGER'POS (IDENT_INT (101)); + FAILED ( "NO EXCEPTION RAISED FOR " & + "T1 := INTEGER'POS (IDENT_INT (101))" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "T1 := INTEGER'POS (IDENT_INT (101));" ); + END; + + BEGIN + T1 := INT (IDENT (INTEGER (INT'FIRST)) - 1); + FAILED ( "NO EXCEPTION RAISED FOR " & + "INT (INT'FIRST - 1)" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "INT (INT'FIRST - 1)" ); + END; + + BEGIN + T1 := INT (IDENT_INT (101)); + FAILED ( "NO EXCEPTION RAISED FOR INT (101)" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INT (101)" ); + END; + + BEGIN + S1 := SMALL (IDENT_INT (101)); + FAILED ( "NO EXCEPTION RAISED FOR SMALL (101)" ); + IF EQUAL (S1, S1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR SMALL (101)" ); + END; + + BEGIN + SN := SUBNEW (IDENT_INT (-101)); + FAILED ( "NO EXCEPTION RAISED FOR SUBNEW (-101)" ); + IF EQUAL (INTEGER (SN), INTEGER (SN)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR SUBNEW (-101)" ); + END; + + BEGIN + P1 := IDENT_INT (101); + SN := SUBNEW (P1); + FAILED ( "NO EXCEPTION RAISED FOR SUBNEW (P1)" ); + IF EQUAL (INTEGER (SN), INTEGER (SN)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR SUBNEW (P1)" ); + END; + + BEGIN + SN := IDENT (0); + P1 := POSITIVE (SN); + FAILED ( "NO EXCEPTION RAISED FOR " & + "POSITIVE (SN)" ); + IF EQUAL (P1, P1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "POSITIVE (SN)" ); + END; + + BEGIN + N1 := IDENT (-1); + L1 := NATURAL (N1); + FAILED ( "NO EXCEPTION RAISED FOR " & + "NATURAL (N1)" ); + IF EQUAL (L1, L1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NATURAL (N1)" ); + END; + + RESULT; +END C46014A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46021a.ada b/gcc/testsuite/ada/acats/tests/c4/c46021a.ada new file mode 100644 index 000000000..198fc7ca6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46021a.ada @@ -0,0 +1,210 @@ +-- C46021A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT FLOATING POINT CONVERSIONS ARE PERFORMED CORRECTLY +-- WHEN THE OPERAND TYPE IS AN INTEGER TYPE, FOR 5-DIGIT PRECISION. + +-- HISTORY: +-- JET 02/12/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C46021A IS + + TYPE FLOAT5 IS DIGITS 5; + TYPE INT IS RANGE -32768..32767; + + TYPE NFLOAT5 IS NEW FLOAT5; + + FUNCTION IDENT (A : FLOAT5) RETURN FLOAT5 IS + BEGIN + IF EQUAL(3,3) THEN + RETURN A; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + FUNCTION IDENT (A : NFLOAT5) RETURN NFLOAT5 IS + BEGIN + IF EQUAL(3,3) THEN + RETURN A; + ELSE + RETURN 0.0; + END IF; + END IDENT; + +BEGIN + TEST ("C46021A", "CHECK THAT FLOATING POINT CONVERSIONS ARE " & + "PERFORMED CORRECTLY WHEN THE OPERAND TYPE " & + "IS AN INTEGER TYPE, FOR 5-DIGIT PRECISION"); + + IF FLOAT5(IDENT_INT(-7)) /= -7.0 THEN + FAILED ("INCORRECT VALUE (1)"); + END IF; + + IF FLOAT5(IDENT_INT(3)) /= 3.0 THEN + FAILED ("INCORRECT VALUE (2)"); + END IF; + + IF FLOAT5(IDENT_INT(-999)) /= -999.0 THEN + FAILED ("INCORRECT VALUE (3)"); + END IF; + + IF FLOAT5(IDENT_INT(101)) /= 101.0 THEN + FAILED ("INCORRECT VALUE (4)"); + END IF; + + IF FLOAT5(IDENT_INT(-32767)) /= -32767.0 THEN + FAILED ("INCORRECT VALUE (5)"); + END IF; + + IF FLOAT5(IDENT_INT(32767)) /= 32767.0 THEN + FAILED ("INCORRECT VALUE (6)"); + END IF; + + IF FLOAT5(-7) /= IDENT(-7.0) THEN + FAILED ("INCORRECT VALUE (7)"); + END IF; + + IF FLOAT5(3) /= IDENT(3.0) THEN + FAILED ("INCORRECT VALUE (8)"); + END IF; + + IF FLOAT5(-999) /= IDENT(-999.0) THEN + FAILED ("INCORRECT VALUE (9)"); + END IF; + + IF FLOAT5(101) /= IDENT(101.0) THEN + FAILED ("INCORRECT VALUE (10)"); + END IF; + + IF FLOAT5(-32767) /= IDENT(-32767.0) THEN + FAILED ("INCORRECT VALUE (11)"); + END IF; + + IF FLOAT5(32767) /= IDENT(32767.0) THEN + FAILED ("INCORRECT VALUE (12)"); + END IF; + + IF FLOAT5(INT'(-7)) /= IDENT(-7.0) THEN + FAILED ("INCORRECT VALUE (13)"); + END IF; + + IF FLOAT5(INT'(3)) /= IDENT(3.0) THEN + FAILED ("INCORRECT VALUE (14)"); + END IF; + + IF FLOAT5(INT'(-999)) /= IDENT(-999.0) THEN + FAILED ("INCORRECT VALUE (15)"); + END IF; + + IF FLOAT5(INT'(101)) /= IDENT(101.0) THEN + FAILED ("INCORRECT VALUE (16)"); + END IF; + + IF FLOAT5(INT'(-32767)) /= IDENT(-32767.0) THEN + FAILED ("INCORRECT VALUE (17)"); + END IF; + + IF FLOAT5(INT'(32767)) /= IDENT(32767.0) THEN + FAILED ("INCORRECT VALUE (18)"); + END IF; + + IF NFLOAT5(IDENT_INT(-7)) /= -7.0 THEN + FAILED ("INCORRECT VALUE (19)"); + END IF; + + IF NFLOAT5(IDENT_INT(3)) /= 3.0 THEN + FAILED ("INCORRECT VALUE (20)"); + END IF; + + IF NFLOAT5(IDENT_INT(-999)) /= -999.0 THEN + FAILED ("INCORRECT VALUE (21)"); + END IF; + + IF NFLOAT5(IDENT_INT(101)) /= 101.0 THEN + FAILED ("INCORRECT VALUE (22)"); + END IF; + + IF NFLOAT5(IDENT_INT(-32767)) /= -32767.0 THEN + FAILED ("INCORRECT VALUE (23)"); + END IF; + + IF NFLOAT5(IDENT_INT(32767)) /= 32767.0 THEN + FAILED ("INCORRECT VALUE (24)"); + END IF; + + IF NFLOAT5(-7) /= IDENT(-7.0) THEN + FAILED ("INCORRECT VALUE (25)"); + END IF; + + IF NFLOAT5(3) /= IDENT(3.0) THEN + FAILED ("INCORRECT VALUE (26)"); + END IF; + + IF NFLOAT5(-999) /= IDENT(-999.0) THEN + FAILED ("INCORRECT VALUE (27)"); + END IF; + + IF NFLOAT5(101) /= IDENT(101.0) THEN + FAILED ("INCORRECT VALUE (28)"); + END IF; + + IF NFLOAT5(-32767) /= IDENT(-32767.0) THEN + FAILED ("INCORRECT VALUE (29)"); + END IF; + + IF NFLOAT5(32767) /= IDENT(32767.0) THEN + FAILED ("INCORRECT VALUE (30)"); + END IF; + + IF NFLOAT5(INT'(-7)) /= IDENT(-7.0) THEN + FAILED ("INCORRECT VALUE (31)"); + END IF; + + IF NFLOAT5(INT'(3)) /= IDENT(3.0) THEN + FAILED ("INCORRECT VALUE (32)"); + END IF; + + IF NFLOAT5(INT'(-999)) /= IDENT(-999.0) THEN + FAILED ("INCORRECT VALUE (33)"); + END IF; + + IF NFLOAT5(INT'(101)) /= IDENT(101.0) THEN + FAILED ("INCORRECT VALUE (34)"); + END IF; + + IF NFLOAT5(INT'(-32767)) /= IDENT(-32767.0) THEN + FAILED ("INCORRECT VALUE (35)"); + END IF; + + IF NFLOAT5(INT'(32767)) /= IDENT(32767.0) THEN + FAILED ("INCORRECT VALUE (36)"); + END IF; + + RESULT; + +END C46021A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46024a.ada b/gcc/testsuite/ada/acats/tests/c4/c46024a.ada new file mode 100644 index 000000000..6f0714f42 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46024a.ada @@ -0,0 +1,136 @@ +-- C46024A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK FLOATING POINT CONVERSIONS WHEN THE TARGET TYPE IS A +-- FIXED POINT TYPE, FOR DIGITS 5. + +-- HISTORY: +-- JET 02/19/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; + +PROCEDURE C46024A IS + + TYPE FLOAT5 IS DIGITS 5; + TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#; + TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#; + TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#; + + F5, F5A, F5B : FLOAT5; + + GENERIC + TYPE F IS DELTA <>; + FUNCTION IDENTG (A : F) RETURN F; + + FUNCTION IDENTG (A : F) RETURN F IS + BEGIN + RETURN A + F(IDENT_INT(0)); + END IDENTG; + + FUNCTION IDENT1 IS NEW IDENTG(FIX1); + FUNCTION IDENT2 IS NEW IDENTG(FIX2); + FUNCTION IDENT3 IS NEW IDENTG(FIX3); + +BEGIN + TEST ("C46024A", "CHECK FLOATING POINT CONVERSIONS WHEN THE " & + "TARGET TYPE IS A FIXED POINT TYPE, FOR " & + "5-DIGIT PRECISION"); + + IF FIX1(FLOAT5'(2#0.1000_0000_0000_0000_00#E-1)) /= + IDENT1(2#0.01#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (1)"); + END IF; + + IF FIX1(FLOAT5'(-2#0.1111_1110_0000_0000_00#E5)) /= + IDENT1(-2#1_1111.11#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (2)"); + END IF; + + IF FIX1(FLOAT5'(-2#0.1010_0111_1111_1111_11#E4)) < + IDENT1(-2#1010.10#) OR + FIX1(FLOAT5'(-2#0.1010_0111_1111_1111_11#E4)) > + IDENT1(-2#1010.01#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (3)"); + END IF; + + IF FIX2(FLOAT5'(-2#0.1000_0000_0000_0000_00#E-3)) /= + IDENT2(-2#0.0001#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (4)"); + END IF; + + IF FIX2(FLOAT5'(2#0.1111_1111_1110_0000_00#E7)) /= + IDENT2(2#111_1111.1111#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (5)"); + END IF; + + F5 := 2#0.1010_1010_1010_1010_10#E5; + IF FIX2(F5) < IDENT2(2#1_0101.0101#) OR + FIX2(F5) > IDENT2(2#1_0101.0110#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (6)"); + END IF; + + IF FIX3(FLOAT5'(2#0.1000_0000_0000_0000_00#E-5)) /= + IDENT3(2#0.000001#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (7)"); + END IF; + + IF FIX3(FLOAT5'(-2#0.1111_1111_1111_1110_00#E9)) /= + IDENT3(-2#1_1111_1111.1111_11#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (8)"); + END IF; + + F5 := -2#0.1010_1010_1010_1010_10#E8; + IF FIX3(F5) < IDENT3(-2#1010_1010.1010_11#) OR + FIX3(F5) > IDENT3(-2#1010_1010.1010_10#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (9)"); + END IF; + + F5A := 2#0.1010_1010_1010_1010_10#E4; + F5B := 2#0.1010_1010_1010_1010_10#E5; + + IF FIX1(F5A) = IDENT1(2#1010.11#) AND + FIX1(-F5A) = IDENT1(-2#1010.11#) AND + FIX1(F5B) = IDENT1(2#1_0101.01#) AND + FIX1(-F5B) = IDENT1(-2#1_0101.01#) THEN + COMMENT ("CONVERSION ROUNDS TO NEAREST"); + ELSIF FIX1(F5A) = IDENT1(2#1010.10#) AND + FIX1(-F5B) = IDENT1(-2#1_0101.10#) THEN + COMMENT ("CONVERSION ROUNDS TO LEAST FIXED-POINT VALUE"); + ELSIF FIX1(F5B) = IDENT1(2#1_0101.10#) AND + FIX1(-F5A) = IDENT1(-2#1010.10#) THEN + COMMENT ("CONVERSION ROUNDS TO GREATEST FIXED-POINT VALUE"); + ELSIF FIX1(F5A) = IDENT1(2#1010.10#) AND + FIX1(-F5A) = IDENT1(-2#1010.10#) THEN + COMMENT ("CONVERSION ROUNDS TOWARD ZERO"); + ELSIF FIX1(F5B) = IDENT1(2#1_0101.10#) AND + FIX1(-F5B) = IDENT1(-2#1_0101.10#) THEN + COMMENT ("CONVERSION ROUNDS AWAY FROM ZERO"); + ELSE + COMMENT ("UNABLE TO DETERMINE CONVERSION PATTERN"); + END IF; + + RESULT; + +END C46024A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46031a.ada b/gcc/testsuite/ada/acats/tests/c4/c46031a.ada new file mode 100644 index 000000000..589833c19 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46031a.ada @@ -0,0 +1,85 @@ +-- C46031A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK CONVERSIONS TO FIXED POINT TYPES WHEN THE OPERAND TYPE +-- IS AN INTEGER TYPE. + +-- HISTORY: +-- JET 07/11/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C46031A IS + + TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#; + TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#; + TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#; + + TYPE NEW_INT IS NEW INTEGER RANGE -16#200# .. 16#200#; + + I : INTEGER; + J : NEW_INT; + + FUNCTION IDENT_NEW (X : NEW_INT) RETURN NEW_INT IS + BEGIN + RETURN X * NEW_INT(IDENT_INT(1)); + END IDENT_NEW; + +BEGIN + TEST ("C46031A", "CHECK CONVERSIONS TO FIXED POINT TYPES WHEN " & + "THE OPERAND TYPE IS AN INTEGER TYPE"); + + I := IDENT_INT(-16#1F#); + IF FIX1(I) /= -16#1F.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (1)"); + END IF; + + J := IDENT_NEW(0); + IF FIX1(J) /= 0.0 THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (2)"); + END IF; + + I := IDENT_INT(16#7F#); + IF FIX2(I) /= 16#7F.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (3)"); + END IF; + + J := IDENT_NEW(16#1#); + IF FIX2(J) /= 16#1.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (4)"); + END IF; + + I := IDENT_INT(-16#55#); + IF FIX3(I) /= -16#55.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (5)"); + END IF; + + J := IDENT_NEW(-16#1#); + IF FIX3(J) /= -16#1.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (6)"); + END IF; + + RESULT; + +END C46031A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46032a.ada b/gcc/testsuite/ada/acats/tests/c4/c46032a.ada new file mode 100644 index 000000000..a89e11598 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46032a.ada @@ -0,0 +1,103 @@ +-- C46032A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK CONVERSIONS TO FIXED POINT TYPES WHEN THE OPERAND TYPE +-- IS A FLOATING POINT TYPE OF 5 DIGITS PRECISION. + +-- HISTORY: +-- JET 07/11/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C46032A IS + + TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#; + TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#; + TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#; + + TYPE FLOAT5 IS DIGITS 5; + + F5 : FLOAT5; + + FUNCTION IDENT5 (X : FLOAT5) RETURN FLOAT5 IS + BEGIN + RETURN X * FLOAT5(IDENT_INT(1)); + END IDENT5; + +BEGIN + TEST ("C46032A", "CHECK CONVERSIONS TO FIXED POINT TYPES WHEN " & + "THE OPERAND TYPE IS A FLOATING POINT TYPE " & + "OF 5 DIGITS PRECISION"); + + F5 := IDENT5(2#0.1100_0000_0000_0000_00#E0); + IF FIX1(F5) /= 16#0.C# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (1)"); + END IF; + + F5 := IDENT5(2#0.1111_1110_0000_0000_00#E5); + IF FIX1(F5) /= 16#1F.C# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (2)"); + END IF; + + F5 := IDENT5(-2#0.1010_1010_1010_1010_10#E2); + IF FIX1(F5) < -16#2.C# OR + FIX1(F5) > -16#2.8# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (3)"); + END IF; + + F5 := IDENT5(2#0.1111_0000_0000_0000_00#E0); + IF FIX2(F5) /= 16#0.F# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (4)"); + END IF; + + F5 := IDENT5(-2#0.1111_1110_0000_0000_00#E7); + IF FIX2(F5) /= -16#7F.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (5)"); + END IF; + + F5 := IDENT5(2#0.1111_1111_1101_0000_00#E7); + IF FIX2(F5) < 16#7F.E# OR + FIX2(F5) > 16#7F.F# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (6)"); + END IF; + + F5 := IDENT5(2#0.1000_0000_0000_0000_00#E-5); + IF FIX3(F5) /= 16#0.04# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (7)"); + END IF; + + F5 := -IDENT5(2#0.1010_1010_1010_1010_00#E9); + IF FIX3(F5) /= -16#155.54# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (8)"); + END IF; + + F5 := IDENT5(2#0.1000_0000_0000_0010_11#E9); + IF FIX3(F5) < 16#100.04# OR + FIX3(F5) > 16#100.08# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (9)"); + END IF; + + RESULT; + +END C46032A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46033a.ada b/gcc/testsuite/ada/acats/tests/c4/c46033a.ada new file mode 100644 index 000000000..7657854e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46033a.ada @@ -0,0 +1,110 @@ +-- C46033A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK CONVERSIONS TO FIXED POINT TYPES WHEN THE OPERAND TYPE +-- IS ANOTHER FIXED POINT TYPE. + +-- HISTORY: +-- JET 07/12/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C46033A IS + + TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#; + TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#; + TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#; + + F1 : FIX1; + F2 : FIX2; + F3 : FIX3; + + GENERIC + TYPE F IS DELTA <>; + FUNCTION IDENT_G (X : F) RETURN F; + + FUNCTION IDENT_G (X : F) RETURN F IS + BEGIN + RETURN X + F(IDENT_INT(0)); + END IDENT_G; + + FUNCTION IDENT IS NEW IDENT_G(FIX1); + FUNCTION IDENT IS NEW IDENT_G(FIX2); + FUNCTION IDENT IS NEW IDENT_G(FIX3); + +BEGIN + TEST ("C46033A", "CHECK CONVERSIONS TO FIXED POINT TYPES WHEN " & + "THE OPERAND TYPE IS ANOTHER FIXED POINT TYPE"); + + F1 := IDENT(-16#1F.C#); + IF FIX1(F1) /= -16#1F.C# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (1)"); + END IF; + + F1 := IDENT(16#0.4#); + IF FIX2(F1) /= 16#0.4# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (2)"); + END IF; + + F1 := IDENT(-16#10.4#); + IF FIX3(F1) /= -16#10.4# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (3)"); + END IF; + + F2 := IDENT(16#3.3#); + IF FIX1(F2) < 16#3.0# OR + FIX1(F2) > 16#3.4# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (4)"); + END IF; + + F2 := IDENT(-16#40.1#); + IF FIX2(F2) /= -16#40.1# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (5)"); + END IF; + + F2 := IDENT(16#0.0#); + IF FIX3(F2) /= 16#0.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (6)"); + END IF; + + F3 := IDENT(-16#0.04#); + IF FIX1(F3) < -16#0.4# OR + FIX1(F3) > -16#0.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (7)"); + END IF; + + F3 := -IDENT(16#55.A8#); + IF FIX2(F3) < -16#55.B# OR + FIX2(F3) > -16#55.A# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (8)"); + END IF; + + F3 := IDENT(16#101.84#); + IF FIX3(F3) /= 16#101.84# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (9)"); + END IF; + + RESULT; + +END C46033A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46041a.ada b/gcc/testsuite/ada/acats/tests/c4/c46041a.ada new file mode 100644 index 000000000..a9fd5d734 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46041a.ada @@ -0,0 +1,141 @@ +-- C46041A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK ARRAY CONVERSIONS WHEN THE TARGET TYPE IS AN UNCONSTRAINED +-- ARRAY TYPE AND THE OPERAND TYPE REQUIRES CONVERSION OF THE INDEX +-- BOUNDS. + +-- R.WILLIAMS 9/8/86 + +WITH REPORT; USE REPORT; +PROCEDURE C46041A IS + + TYPE INT IS RANGE -100 .. 100; + TYPE NEWINTEGER IS NEW INTEGER; + + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + + TYPE NDAY1 IS NEW DAY RANGE SUN .. FRI; + TYPE NDAY2 IS NEW DAY RANGE MON .. SAT; + + TYPE NNDAY1 IS NEW NDAY1; + + FUNCTION IDENT (X : INT) RETURN INT IS + BEGIN + RETURN INT'VAL (IDENT_INT (INT'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NEWINTEGER) RETURN NEWINTEGER IS + BEGIN + RETURN NEWINTEGER'VAL (IDENT_INT (NEWINTEGER'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NDAY1) RETURN NDAY1 IS + BEGIN + RETURN NDAY1'VAL (IDENT_INT (NDAY1'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NDAY2) RETURN NDAY2 IS + BEGIN + RETURN NDAY2'VAL (IDENT_INT (NDAY2'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NNDAY1) RETURN NNDAY1 IS + BEGIN + RETURN NNDAY1'VAL (IDENT_INT (NNDAY1'POS (X))); + END IDENT; + +BEGIN + TEST ( "C46041A", "CHECK ARRAY CONVERSIONS WHEN THE TARGET " & + "TYPE IS AN UNCONSTRAINED ARRAY TYPE AND " & + "THE OPERAND TYPE REQUIRES CONVERSION OF " & + "THE INDEX BOUNDS" ); + + DECLARE + + TYPE UNARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE UNARR2 IS ARRAY (INTEGER RANGE <>, NDAY1 RANGE <>) + OF INTEGER; + + TYPE ARR1 IS ARRAY (INT RANGE <>) OF INTEGER; + A1 : ARR1 (IDENT (11) .. IDENT (20)) := + (IDENT (11) .. IDENT (20) => 0); + + TYPE ARR2 IS ARRAY (INT RANGE <>, NDAY2 RANGE <>) + OF INTEGER; + A2 : ARR2 (IDENT (11) .. IDENT (20), + IDENT (TUE) .. IDENT (THU)) := + (IDENT (11) .. IDENT (20) => + (IDENT (TUE) .. IDENT (THU) => 0)); + + TYPE ARR3 IS ARRAY (NEWINTEGER RANGE <>, NNDAY1 RANGE <>) + OF INTEGER; + A3 : ARR3 (IDENT (11) .. IDENT (20), + IDENT (TUE) .. IDENT (THU)) := + (IDENT (11) .. IDENT (20) => + (IDENT (TUE) .. IDENT (THU) => 0)); + + PROCEDURE CHECK (A : UNARR1) IS + BEGIN + IF A'FIRST /= 11 OR A'LAST /= 20 THEN + FAILED ( "INCORRECT CONVERSION OF UNARR1 (A1)" ); + END IF; + END CHECK; + + PROCEDURE CHECK (A : UNARR2; STR : STRING) IS + BEGIN + IF A'FIRST (1) /= 11 OR A'LAST /= 20 OR + A'FIRST (2) /= TUE OR A'LAST (2) /= THU THEN + FAILED ( "INCORRECT CONVERSION OF UNARR2 (A" & + STR & ")" ); + END IF; + END CHECK; + + BEGIN + BEGIN + CHECK (UNARR1 (A1)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BY 'UNARR1 (A1)'" ); + END; + + BEGIN + CHECK (UNARR2 (A2), "2"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BY 'UNARR2 (A2)'" ); + END; + + BEGIN + CHECK (UNARR2 (A3), "3"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BY 'UNARR2 (A3)'" ); + END; + + END; + + RESULT; +END C46041A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46042a.ada b/gcc/testsuite/ada/acats/tests/c4/c46042a.ada new file mode 100644 index 000000000..2099ca6bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46042a.ada @@ -0,0 +1,146 @@ +-- C46042A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK ARRAY CONVERSIONS WHEN THE TARGET TYPE IS A CONSTRAINED +-- ARRAY TYPE AND THE OPERAND TYPE HAS BOUNDS THAT DO NOT BELONG TO +-- THE BASE TYPE OF THE TARGET TYPE'S INDEX SUBTYPE. + +-- R.WILLIAMS 9/8/86 + +WITH REPORT; USE REPORT; +PROCEDURE C46042A IS + + TYPE INT IS RANGE -100 .. 100; + + TYPE NEWINTEGER IS NEW INTEGER; + + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + + TYPE NDAY1 IS NEW DAY RANGE MON .. FRI; + TYPE NDAY2 IS NEW DAY RANGE MON .. FRI; + + TYPE NNDAY1 IS NEW NDAY1; + + FUNCTION IDENT (X : INT) RETURN INT IS + BEGIN + RETURN INT'VAL (IDENT_INT (INT'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NEWINTEGER) RETURN NEWINTEGER IS + BEGIN + RETURN NEWINTEGER'VAL (IDENT_INT (NEWINTEGER'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NDAY1) RETURN NDAY1 IS + BEGIN + RETURN NDAY1'VAL (IDENT_INT (NDAY1'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NDAY2) RETURN NDAY2 IS + BEGIN + RETURN NDAY2'VAL (IDENT_INT (NDAY2'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NNDAY1) RETURN NNDAY1 IS + BEGIN + RETURN NNDAY1'VAL (IDENT_INT (NNDAY1'POS (X))); + END IDENT; + +BEGIN + TEST ( "C46042A", "CHECK ARRAY CONVERSIONS WHEN THE TARGET " & + "TYPE IS A CONSTRAINED ARRAY TYPE AND THE " & + "OPERAND TYPE HAS BOUNDS THAT DO NOT " & + "BELONG TO THE BASE TYPE OF THE TARGET " & + "TYPE'S INDEX SUBTYPE" ); + + DECLARE + + TYPE UNARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE CONARR1 IS UNARR1 (IDENT_INT (1) .. IDENT_INT (10)); + + TYPE UNARR2 IS ARRAY (INTEGER RANGE <>, NDAY1 RANGE <>) + OF INTEGER; + SUBTYPE CONARR2 IS UNARR2 (IDENT_INT (1) .. IDENT_INT (10), + IDENT (MON) .. IDENT (TUE)); + + TYPE ARR1 IS ARRAY (INT RANGE <>) OF INTEGER; + A1 : ARR1 (IDENT (11) .. IDENT (20)) := + (IDENT (11) .. IDENT (20) => 0); + + TYPE ARR2 IS ARRAY (INT RANGE <>, NDAY2 RANGE <>) + OF INTEGER; + A2 : ARR2 (IDENT (11) .. IDENT (20), + IDENT (WED) .. IDENT (THU)) := + (IDENT (11) .. IDENT (20) => + (IDENT (WED) .. IDENT (THU) => 0)); + + TYPE ARR3 IS ARRAY (NEWINTEGER RANGE <>, NNDAY1 RANGE <>) + OF INTEGER; + A3 : ARR3 (IDENT (11) .. IDENT (20), + IDENT (WED) .. IDENT (THU)) := + (IDENT (11) .. IDENT (20) => + (IDENT (WED) .. IDENT (THU) => 0)); + + PROCEDURE CHECK (A : UNARR1) IS + BEGIN + IF A'FIRST /= 1 OR A'LAST /= 10 THEN + FAILED ( "INCORRECT CONVERSION OF UNARR1 (A1)" ); + END IF; + END CHECK; + + PROCEDURE CHECK (A : UNARR2; STR : STRING) IS + BEGIN + IF A'FIRST (1) /= 1 OR A'LAST /= 10 OR + A'FIRST (2) /= MON OR A'LAST (2) /= TUE THEN + FAILED ( "INCORRECT CONVERSION OF UNARR2 (A" & + STR & ")" ); + END IF; + END CHECK; + + BEGIN + BEGIN + CHECK (CONARR1 (A1)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BY 'CONARR1 (A1)'" ); + END; + + BEGIN + CHECK (CONARR2 (A2), "2"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BY 'CONARR2 (A2)'" ); + END; + + BEGIN + CHECK (CONARR2 (A3), "3"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BY 'CONARR2 (A3)'" ); + END; + + END; + + RESULT; +END C46042A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46043b.ada b/gcc/testsuite/ada/acats/tests/c4/c46043b.ada new file mode 100644 index 000000000..ee973a605 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46043b.ada @@ -0,0 +1,148 @@ +-- C46043B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR CONVERSION TO AN +-- UNCONSTRAINED ARRAY TYPE IF, FOR A NON-NULL DIMENSION OF THE +-- OPERAND TYPE, ONE BOUND DOES NOT BELONG TO THE CORRESPONDING INDEX +-- SUBTYPE OF THE TARGET TYPE. + +-- R.WILLIAMS 9/8/86 + +WITH REPORT; USE REPORT; +PROCEDURE C46043B IS + + SUBTYPE SUBINT IS INTEGER RANGE IDENT_INT (0) .. IDENT_INT (9); + +BEGIN + TEST ( "C46043B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & + "CONVERSION TO AN UNCONSTRAINED ARRAY TYPE " & + "IF, FOR A NON-NULL DIMENSION OF THE OPERAND " & + "TYPE, ONE BOUND DOES NOT BELONG TO THE " & + "CORRESPONDING INDEX SUBTYPE OF THE TARGET " & + "TYPE" ); + + DECLARE + TYPE ARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER; + A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10)); + + TYPE ARR2 IS ARRAY (SUBINT RANGE <>) OF INTEGER; + + PROCEDURE CHECK (A : ARR2) IS + BEGIN + FAILED ( "NO EXCEPTION RAISED WITH ONE DIMENSIONAL " & + "ARRAYS" ); + END CHECK; + + BEGIN + A1 := (A1'RANGE => 0); + CHECK (ARR2 (A1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH ONE " & + "DIMENSIONAL ARRAYS" ); + END; + + DECLARE + TYPE ARR1 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + INTEGER; + A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10), + IDENT_INT (1) .. IDENT_INT (1)); + + TYPE ARR2 IS ARRAY (SUBINT RANGE <>, INTEGER RANGE <>) OF + INTEGER; + + PROCEDURE CHECK (A : ARR2) IS + BEGIN + FAILED ( "NO EXCEPTION RAISED WITH TWO DIMENSIONAL " & + "ARRAYS" ); + END CHECK; + + BEGIN + A1 := (A1'RANGE (1) => (A1'RANGE (2) => 0)); + CHECK (ARR2 (A1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH TWO " & + "DIMENSIONAL ARRAYS" ); + END; + + DECLARE + TYPE ARR1 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + INTEGER; + A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10), + IDENT_INT (1) .. IDENT_INT (0)); + + TYPE ARR2 IS ARRAY (SUBINT RANGE <>, INTEGER RANGE <>) OF + INTEGER; + + PROCEDURE CHECK (A : ARR2) IS + BEGIN + FAILED ( "NO EXCEPTION RAISED WITH NULL ARRAYS - 1" ); + END CHECK; + + BEGIN + A1 := (A1'RANGE (1) => (A1'RANGE (2) => 0)); + CHECK (ARR2 (A1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "WITH NULL ARRAYS - 1" ); + END; + + DECLARE + TYPE ARR1 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + INTEGER; + A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10), + IDENT_INT (1) .. IDENT_INT (0)); + + SUBTYPE NOINT IS INTEGER + RANGE IDENT_INT (1) .. IDENT_INT (0); + + TYPE ARR2 IS ARRAY (SUBINT RANGE <>, NOINT RANGE <>) OF + INTEGER; + + PROCEDURE CHECK (A : ARR2) IS + BEGIN + FAILED ( "NO EXCEPTION RAISED WITH NULL ARRAYS - 2" ); + END CHECK; + + BEGIN + A1 := (A1'RANGE (1) => (A1'RANGE (2) => 0)); + CHECK (ARR2 (A1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "WITH NULL ARRAYS - 2" ); + END; + + RESULT; +END C46043B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46044b.ada b/gcc/testsuite/ada/acats/tests/c4/c46044b.ada new file mode 100644 index 000000000..90ea0e494 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46044b.ada @@ -0,0 +1,235 @@ +-- C46044B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT ERROR IS RAISED FOR CONVERSION TO A +-- CONSTRAINED ARRAY TYPE IF THE TARGET TYPE IS NON-NULL AND +-- CORRESPONDING DIMENSIONS OF THE TARGET AND OPERAND DO NOT HAVE +-- THE SAME LENGTH. ALSO, CHECK THAT CONSTRAINT_ERROR IS RAISED IF +-- THE TARGET TYPE IS NULL AND THE OPERAND TYPE IS NON-NULL. + +-- R.WILLIAMS 9/8/86 + +WITH REPORT; USE REPORT; +PROCEDURE C46044B IS + + TYPE ARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + SUBTYPE CARR1A IS ARR1 (IDENT_INT (1) .. IDENT_INT (6)); + C1A : CARR1A := (CARR1A'RANGE => 0); + + SUBTYPE CARR1B IS ARR1 (IDENT_INT (2) .. IDENT_INT (5)); + C1B : CARR1B := (CARR1B'RANGE => 0); + + SUBTYPE CARR1N IS ARR1 (IDENT_INT (1) .. IDENT_INT (0)); + C1N : CARR1N := (CARR1N'RANGE => 0); + + TYPE ARR2 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + INTEGER; + + SUBTYPE CARR2A IS ARR2 (IDENT_INT (1) .. IDENT_INT (2), + IDENT_INT (1) .. IDENT_INT (2)); + C2A : CARR2A := (CARR2A'RANGE (1) => (CARR2A'RANGE (2) => 0)); + + SUBTYPE CARR2B IS ARR2 (IDENT_INT (0) .. IDENT_INT (2), + IDENT_INT (0) .. IDENT_INT (2)); + C2B : CARR2B := (CARR2B'RANGE (1) => (CARR2B'RANGE (2) => 0)); + + SUBTYPE CARR2N IS ARR2 (IDENT_INT (2) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (2)); + C2N : CARR2N := (CARR2N'RANGE (1) => (CARR2N'RANGE (2) => 0)); + + PROCEDURE CHECK1 (A : ARR1; STR : STRING) IS + BEGIN + FAILED ( "NO EXCEPTION RAISED - " & STR ); + END CHECK1; + + PROCEDURE CHECK2 (A : ARR2; STR : STRING) IS + BEGIN + FAILED ( "NO EXCEPTION RAISED - " & STR ); + END CHECK2; + +BEGIN + TEST ( "C46044B", "CHECK THAT CONSTRAINT ERROR IS RAISED FOR " & + "CONVERSION TO A CONSTRAINED ARRAY TYPE " & + "IF THE TARGET TYPE IS NON-NULL AND " & + "CORRESPONDING DIMENSIONS OF THE TARGET AND " & + "OPERAND DO NOT HAVE THE SAME LENGTH. " & + "ALSO, CHECK THAT CONSTRAINT_ERROR IS " & + "RAISED IF THE TARGET TYPE IS NULL AND " & + "THE OPERAND TYPE IS NON-NULL" ); + + BEGIN -- (A). + C1A := C1B; + CHECK1 (C1A, "(A)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (A)" ); + END; + + BEGIN -- (B). + CHECK1 (CARR1A (C1B), "(B)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (B)" ); + END; + + BEGIN -- (C). + C1B := C1A; + CHECK1 (C1B, "(C)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (C)" ); + END; + + BEGIN -- (D). + CHECK1 (CARR1B (C1A), "(D)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (D)" ); + END; + + BEGIN -- (E). + C1A := C1N; + CHECK1 (C1A, "(E)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (E)" ); + END; + + BEGIN -- (F). + CHECK1 (CARR1A (C1N), "(F)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (F)" ); + END; + + BEGIN -- (G). + C2A := C2B; + CHECK2 (C2A, "(G)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (G)" ); + END; + + BEGIN -- (H). + CHECK2 (CARR2A (C2B), "(H)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (H)" ); + END; + + BEGIN -- (I). + C2B := C2A; + CHECK2 (C2B, "(I)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (I)" ); + END; + + BEGIN -- (J). + CHECK2 (CARR2A (C2B), "(J)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (J)" ); + END; + + BEGIN -- (K). + C2A := C2N; + CHECK2 (C2A, "(K)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (K)" ); + END; + + BEGIN -- (L). + CHECK2 (CARR2A (C2N), "(L)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (L)" ); + END; + + BEGIN -- (M). + C1N := C1A; + CHECK1 (C1N, "(M)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (M)" ); + END; + + BEGIN -- (N). + CHECK1 (CARR1N (C1A), "(N)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (N)" ); + END; + + BEGIN -- (O). + C2N := C2A; + CHECK2 (C2N, "(O)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (O)" ); + END; + + BEGIN -- (P). + CHECK2 (CARR2N (C2A), "(P)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (P)" ); + END; + + RESULT; +END C46044B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46051a.ada b/gcc/testsuite/ada/acats/tests/c4/c46051a.ada new file mode 100644 index 000000000..9468e8f76 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46051a.ada @@ -0,0 +1,414 @@ +-- C46051A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ENUMERATION, RECORD, ACCESS, PRIVATE, AND TASK VALUES CAN +-- BE CONVERTED IF THE OPERAND AND TARGET TYPES ARE RELATED BY +-- DERIVATION. + +-- R.WILLIAMS 9/8/86 + +WITH REPORT; USE REPORT; +PROCEDURE C46051A IS + +BEGIN + TEST ( "C46051A", "CHECK THAT ENUMERATION, RECORD, ACCESS, " & + "PRIVATE, AND TASK VALUES CAN BE CONVERTED " & + "IF THE OPERAND AND TARGET TYPES ARE " & + "RELATED BY DERIVATION" ); + + DECLARE + TYPE ENUM IS (A, AB, ABC, ABCD); + E : ENUM := ABC; + + TYPE ENUM1 IS NEW ENUM; + E1 : ENUM1 := ENUM1'VAL (IDENT_INT (2)); + + TYPE ENUM2 IS NEW ENUM; + E2 : ENUM2 := ABC; + + TYPE NENUM1 IS NEW ENUM1; + NE : NENUM1 := NENUM1'VAL (IDENT_INT (2)); + BEGIN + IF ENUM (E) /= E THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM (E)'" ); + END IF; + + IF ENUM (E1) /= E THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM (E1)'" ); + END IF; + + IF ENUM1 (E2) /= E1 THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM1 (E2)'" ); + END IF; + + IF ENUM2 (NE) /= E2 THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM2 (NE)'" ); + END IF; + + IF NENUM1 (E) /= NE THEN + FAILED ( "INCORRECT CONVERSION OF 'NENUM (E)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "ENUMERATION TYPES" ); + END; + + DECLARE + TYPE REC IS + RECORD + NULL; + END RECORD; + + R : REC; + + TYPE REC1 IS NEW REC; + R1 : REC1; + + TYPE REC2 IS NEW REC; + R2 : REC2; + + TYPE NREC1 IS NEW REC1; + NR : NREC1; + BEGIN + IF REC (R) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'REC (R)'" ); + END IF; + + IF REC (R1) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'REC (R1)'" ); + END IF; + + IF REC1 (R2) /= R1 THEN + FAILED ( "INCORRECT CONVERSION OF 'REC1 (R2)'" ); + END IF; + + IF REC2 (NR) /= R2 THEN + FAILED ( "INCORRECT CONVERSION OF 'REC2 (NR)'" ); + END IF; + + IF NREC1 (R) /= NR THEN + FAILED ( "INCORRECT CONVERSION OF 'NREC (R)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "RECORD TYPES" ); + END; + + DECLARE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE CREC IS REC (3); + R : CREC; + + TYPE CREC1 IS NEW REC (3); + R1 : CREC1; + + TYPE CREC2 IS NEW REC (3); + R2 : CREC2; + + TYPE NCREC1 IS NEW CREC1; + NR : NCREC1; + BEGIN + IF CREC (R) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'CREC (R)'" ); + END IF; + + IF CREC (R1) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'CREC (R1)'" ); + END IF; + + IF CREC1 (R2) /= R1 THEN + FAILED ( "INCORRECT CONVERSION OF 'CREC1 (R2)'" ); + END IF; + + IF CREC2 (NR) /= R2 THEN + FAILED ( "INCORRECT CONVERSION OF 'CREC2 (NR)'" ); + END IF; + + IF NCREC1 (R) /= NR THEN + FAILED ( "INCORRECT CONVERSION OF 'NCREC (R)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "RECORD TYPES WITH DISCRIMINANTS" ); + END; + + DECLARE + TYPE REC IS + RECORD + NULL; + END RECORD; + + TYPE ACCREC IS ACCESS REC; + AR : ACCREC; + + TYPE ACCREC1 IS NEW ACCREC; + AR1 : ACCREC1; + + TYPE ACCREC2 IS NEW ACCREC; + AR2 : ACCREC2; + + TYPE NACCREC1 IS NEW ACCREC1; + NAR : NACCREC1; + + FUNCTION F (A : ACCREC) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (0); + END F; + + FUNCTION F (A : ACCREC1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (1); + END F; + + FUNCTION F (A : ACCREC2) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (2); + END F; + + FUNCTION F (A : NACCREC1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (3); + END F; + + BEGIN + IF F (ACCREC (AR)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'ACCREC (AR)'" ); + END IF; + + IF F (ACCREC (AR1)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'ACCREC (AR1)'" ); + END IF; + + IF F (ACCREC1 (AR2)) /= 1 THEN + FAILED ( "INCORRECT CONVERSION OF 'ACCREC1 (AR2)'" ); + END IF; + + IF F (ACCREC2 (NAR)) /= 2 THEN + FAILED ( "INCORRECT CONVERSION OF 'ACCREC2 (NAR)'" ); + END IF; + + IF F (NACCREC1 (AR)) /= 3 THEN + FAILED ( "INCORRECT CONVERSION OF 'NACCREC (AR)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "ACCESS TYPES" ); + END; + + DECLARE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC; + + SUBTYPE CACCR IS ACCR (3); + AR : CACCR; + + TYPE CACCR1 IS NEW ACCR (3); + AR1 : CACCR1; + + TYPE CACCR2 IS NEW ACCR (3); + AR2 : CACCR2; + + TYPE NCACCR1 IS NEW CACCR1; + NAR : NCACCR1; + + FUNCTION F (A : CACCR) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (0); + END F; + + FUNCTION F (A : CACCR1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (1); + END F; + + FUNCTION F (A : CACCR2) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (2); + END F; + + FUNCTION F (A : NCACCR1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (3); + END F; + + BEGIN + IF F (CACCR (AR)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'CACCR (AR)'" ); + END IF; + + IF F (CACCR (AR1)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'CACCR (AR1)'" ); + END IF; + + IF F (CACCR1 (AR2)) /= 1 THEN + FAILED ( "INCORRECT CONVERSION OF 'CACCR1 (AR2)'" ); + END IF; + + IF F (CACCR2 (NAR)) /= 2 THEN + FAILED ( "INCORRECT CONVERSION OF 'CACCR2 (NAR)'" ); + END IF; + + IF F (NCACCR1 (AR)) /= 3 THEN + FAILED ( "INCORRECT CONVERSION OF 'NCACCR (AR)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "CONSTRAINED ACCESS TYPES" ); + END; + + DECLARE + PACKAGE PKG1 IS + TYPE PRIV IS PRIVATE; + PRIVATE + TYPE PRIV IS + RECORD + NULL; + END RECORD; + END PKG1; + + USE PKG1; + + PACKAGE PKG2 IS + R : PRIV; + + TYPE PRIV1 IS NEW PRIV; + R1 : PRIV1; + + TYPE PRIV2 IS NEW PRIV; + R2 : PRIV2; + END PKG2; + + USE PKG2; + + PACKAGE PKG3 IS + TYPE NPRIV1 IS NEW PRIV1; + NR : NPRIV1; + END PKG3; + + USE PKG3; + BEGIN + IF PRIV (R) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'PRIV (R)'" ); + END IF; + + IF PRIV (R1) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'PRIV (R1)'" ); + END IF; + + IF PRIV1 (R2) /= R1 THEN + FAILED ( "INCORRECT CONVERSION OF 'PRIV1 (R2)'" ); + END IF; + + IF PRIV2 (NR) /= R2 THEN + FAILED ( "INCORRECT CONVERSION OF 'PRIV2 (NR)'" ); + END IF; + + IF NPRIV1 (R) /= NR THEN + FAILED ( "INCORRECT CONVERSION OF 'NPRIV (R)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "PRIVATE TYPES" ); + END; + + DECLARE + TASK TYPE TK; + T : TK; + + TYPE TK1 IS NEW TK; + T1 : TK1; + + TYPE TK2 IS NEW TK; + T2 : TK2; + + TYPE NTK1 IS NEW TK1; + NT : NTK1; + + TASK BODY TK IS + BEGIN + NULL; + END; + + FUNCTION F (T : TK) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (0); + END F; + + FUNCTION F (T : TK1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (1); + END F; + + FUNCTION F (T : TK2) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (2); + END F; + + FUNCTION F (T : NTK1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (3); + END F; + + BEGIN + IF F (TK (T)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'TK (T))'" ); + END IF; + + IF F (TK (T1)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'TK (T1))'" ); + END IF; + + IF F (TK1 (T2)) /= 1 THEN + FAILED ( "INCORRECT CONVERSION OF 'TK1 (T2))'" ); + END IF; + + IF F (TK2 (NT)) /= 2 THEN + FAILED ( "INCORRECT CONVERSION OF 'TK2 (NT))'" ); + END IF; + + IF F (NTK1 (T)) /= 3 THEN + FAILED ( "INCORRECT CONVERSION OF 'NTK (T))'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "TASK TYPES" ); + END; + + RESULT; +END C46051A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46051b.ada b/gcc/testsuite/ada/acats/tests/c4/c46051b.ada new file mode 100644 index 000000000..402992da4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46051b.ada @@ -0,0 +1,102 @@ +-- C46051B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT ENUMERATION VALUES CAN BE CONVERTED IF THE OPERAND +-- AND TARGET TYPES ARE RELATED BY DERIVATION, EVEN IF THE OPERAND +-- AND TARGET TYPES HAVE DIFFERENT REPRESENTATIONS. + +-- HISTORY: +-- JET 07/13/88 CREATED ORIGINAL TEST. +-- RJW 08/28/89 REMOVED APPLICABILITY CRITERIA AND CHANGED +-- EXTENSION TO 'ADA'. CHANGED THE CODES IN SECOND +-- ENUMERATION REPRESENTATION CLAUSE. + +WITH REPORT; USE REPORT; +PROCEDURE C46051B IS + + TYPE ENUM IS (WE, LOVE, WRITING, TESTS); + + TYPE ENUM1 IS NEW ENUM; + FOR ENUM1 USE + (WE => -1, LOVE => 0, WRITING => 3, TESTS => 9); + + TYPE ENUM2 IS NEW ENUM; + FOR ENUM2 USE + (WE => 10, LOVE => 15, WRITING => 16, TESTS => 19); + + TYPE ENUM3 IS NEW ENUM1; + + E : ENUM := ENUM'VAL (IDENT_INT (0)); + E1 : ENUM1 := ENUM1'VAL (IDENT_INT (1)); + E2 : ENUM2 := ENUM2'VAL (IDENT_INT (2)); + E3 : ENUM3 := ENUM3'VAL (IDENT_INT (3)); + +BEGIN + TEST ( "C46051B", "CHECK THAT ENUMERATION VALUES CAN BE " & + "CONVERTED IF THE OPERAND AND TARGET TYPES " & + "ARE RELATED BY DERIVATION, EVEN IF THE " & + "OPERAND AND TARGET TYPES HAVE DIFFERENT " & + "REPRESENTATIONS"); + + IF ENUM1 (E) /= WE THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM1 (E)'" ); + END IF; + + IF ENUM (E1) /= LOVE THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM (E1)'" ); + END IF; + + IF ENUM1 (E2) /= WRITING THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM1 (E2)'" ); + END IF; + + IF ENUM2 (E3) /= TESTS THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM2 (E3)'" ); + END IF; + + IF ENUM (E) /= WE THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM (E)'" ); + END IF; + + IF ENUM2 (E1) /= LOVE THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM2 (E1)'" ); + END IF; + + IF ENUM3 (E2) /= WRITING THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM3 (E2)'" ); + END IF; + + IF ENUM (E3) /= TESTS THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM (E3)'" ); + END IF; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "ENUMERATION TYPES" ); + RESULT; +END C46051B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46051c.ada b/gcc/testsuite/ada/acats/tests/c4/c46051c.ada new file mode 100644 index 000000000..c5cfd8fa7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46051c.ada @@ -0,0 +1,120 @@ +-- C46051C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT RECORD VALUES CAN BE CONVERTED IF THE OPERAND +-- AND TARGET TYPES ARE RELATED BY DERIVATION, EVEN IF THE OPERAND +-- AND TARGET TYPES HAVE DIFFERENT REPRESENTATIONS. + +-- HISTORY: +-- JET 07/13/88 CREATED ORIGINAL TEST. +-- RJW 08/28/89 REMOVED APPLICABILITY CRITERIA AND CHANGED +-- EXTENSION TO 'ADA'. + +WITH REPORT; USE REPORT; +WITH SYSTEM; + +PROCEDURE C46051C IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE+SYSTEM.STORAGE_UNIT-1) / SYSTEM.STORAGE_UNIT; + + TYPE ARR IS ARRAY (1..2) OF INTEGER; + + TYPE REC IS RECORD + F1 : INTEGER; + F2 : INTEGER; + F3 : INTEGER; + END RECORD; + + TYPE REC1 IS NEW REC; + FOR REC1 USE + RECORD + F1 AT 0 RANGE 0 .. INTEGER'SIZE - 1; + F2 AT 1*UNITS_PER_INTEGER RANGE 0..INTEGER'SIZE - 1; + F3 AT 3*UNITS_PER_INTEGER RANGE 0..INTEGER'SIZE - 1; + END RECORD; + + TYPE REC2 IS NEW REC; + FOR REC2 USE + RECORD + F1 AT 0 RANGE 0 .. INTEGER'SIZE - 1; + F2 AT 2*UNITS_PER_INTEGER RANGE 0..INTEGER'SIZE - 1; + F3 AT 3*UNITS_PER_INTEGER RANGE 0..INTEGER'SIZE - 1; + END RECORD; + + TYPE REC3 IS NEW REC1; + + R : REC := (IDENT_INT (0), 1, 2); + R1 : REC1 := (IDENT_INT (1), 2, 3); + R2 : REC2 := (IDENT_INT (2), 3, 4); + R3 : REC3 := (IDENT_INT (3), 4, 5); + +BEGIN + TEST ( "C46051C", "CHECK THAT RECORD VALUES CAN BE " & + "CONVERTED IF THE OPERAND AND TARGET TYPES " & + "ARE RELATED BY DERIVATION, EVEN IF THE " & + "OPERAND AND TARGET TYPES HAVE DIFFERENT " & + "REPRESENTATIONS"); + + IF REC1(R) /= (0,1,2) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC1 (R)'" ); + END IF; + + IF REC (R1) /= (1,2,3) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC (R1)'" ); + END IF; + + IF REC1 (R2) /= (2,3,4) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC1 (R2)'" ); + END IF; + + IF REC2 (R3) /= (3,4,5) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC2 (R3)'" ); + END IF; + + IF REC (R) /= (0,1,2) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC (R)'" ); + END IF; + + IF REC2 (R1) /= (1,2,3) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC2 (R1)'" ); + END IF; + + IF REC3 (R2) /= (2,3,4) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC3 (R2)'" ); + END IF; + + IF REC (R3) /= (3,4,5) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC (R3)'" ); + END IF; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "RECORD TYPES" ); + RESULT; +END C46051C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46052a.ada b/gcc/testsuite/ada/acats/tests/c4/c46052a.ada new file mode 100644 index 000000000..7e69844ad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46052a.ada @@ -0,0 +1,100 @@ +-- C46052A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR CONVERSION TO AN +-- ENUMERATION TYPE IF THE VALUE OF THE OPERAND DOES NOT BELONG TO THE +-- RANGE OF ENUMERATION VALUES FOR THE TARGET SUBTYPE. + +-- R.WILLIAMS 9/9/86 + +WITH REPORT; USE REPORT; +PROCEDURE C46052A IS + + TYPE ENUM IS (A, AB, ABC, ABCD); + E : ENUM := ENUM'VAL (IDENT_INT (0)); + + FUNCTION IDENT (E : ENUM) RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (IDENT_INT (ENUM'POS (E))); + END IDENT; + +BEGIN + TEST ( "C46052A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & + "CONVERSION TO AN ENUMERATION TYPE IF THE " & + "VALUE OF THE OPERAND DOES NOT BELONG TO " & + "THE RANGE OF ENUMERATION VALUES FOR THE " & + "TARGET SUBTYPE" ); + + DECLARE + SUBTYPE SENUM IS ENUM RANGE AB .. ABCD; + BEGIN + E := IDENT (SENUM (E)); + FAILED ( "NO EXCEPTION RAISED FOR 'SENUM (E)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'SENUM (E)'" ); + END; + + DECLARE + SUBTYPE NOENUM IS ENUM RANGE ABCD .. AB; + BEGIN + E := IDENT (NOENUM (E)); + FAILED ( "NO EXCEPTION RAISED FOR 'NOENUM (E)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'NOENUM (E)'" ); + END; + + DECLARE + SUBTYPE SCHAR IS CHARACTER RANGE 'C' .. 'R'; + A : CHARACTER := IDENT_CHAR ('A'); + BEGIN + A := IDENT_CHAR (SCHAR (A)); + FAILED ( "NO EXCEPTION RAISED FOR 'SCHAR (A)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'SCHAR (A)'" ); + END; + + DECLARE + SUBTYPE FRANGE IS BOOLEAN RANGE FALSE .. FALSE; + T : BOOLEAN := IDENT_BOOL (TRUE); + BEGIN + T := IDENT_BOOL (FRANGE (T)); + FAILED ( "NO EXCEPTION RAISED FOR 'FRANGE (T)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'FRANGE (T)'" ); + END; + + RESULT; +END C46052A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46053a.ada b/gcc/testsuite/ada/acats/tests/c4/c46053a.ada new file mode 100644 index 000000000..53c17c4b9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46053a.ada @@ -0,0 +1,139 @@ +-- C46053A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR CONVERSION TO A +-- CONSTRAINED RECORD, PRIVATE, OR LIMITED PRIVATE SUBTYPE IF THE +-- DISCRIMINANTS OF THE TARGET SUBTYPE DO NOT EQUAL THOSE OF THE +-- OPERAND. + +-- R.WILLIAMS 9/9/86 + +WITH REPORT; USE REPORT; +PROCEDURE C46053A IS + +BEGIN + TEST ( "C46053A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & + "CONVERSION TO A CONSTRAINED RECORD, " & + "PRIVATE, OR LIMITED PRIVATE SUBTYPE IF " & + "THE DISCRIMINANTS OF THE TARGET SUBTYPE DO " & + "NOT EQUAL THOSE OF THE OPERAND" ); + + DECLARE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE REC3 IS REC (IDENT_INT (3)); + R : REC (IDENT_INT (1)); + + PROCEDURE PROC (R : REC) IS + I : INTEGER; + BEGIN + I := IDENT_INT (R.D); + END PROC; + + BEGIN + PROC (REC3 (R)); + FAILED ( "NO EXCEPTION RAISED FOR 'REC3 (R)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'REC3 (R)'" ); + END; + + DECLARE + PACKAGE PKG1 IS + TYPE PRIV (D : INTEGER) IS PRIVATE; + SUBTYPE PRIV3 IS PRIV (IDENT_INT (3)); + PRIVATE + TYPE PRIV (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG1; + + USE PKG1; + + PACKAGE PKG2 IS + P : PRIV (IDENT_INT (0)); + END PKG2; + + USE PKG2; + + PROCEDURE PROC (P : PRIV) IS + I : INTEGER; + BEGIN + I := IDENT_INT (P.D); + END PROC; + + BEGIN + PROC (PRIV3 (P)); + FAILED ( "NO EXCEPTION RAISED FOR 'PRIV3 (P)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'PRIV3 (P)'" ); + END; + + DECLARE + PACKAGE PKG1 IS + TYPE LIM (D : INTEGER) IS LIMITED PRIVATE; + SUBTYPE LIM3 IS LIM (IDENT_INT (3)); + PRIVATE + TYPE LIM (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG1; + + USE PKG1; + + PACKAGE PKG2 IS + L : LIM (IDENT_INT (0)); + I : INTEGER; + END PKG2; + + USE PKG2; + + PROCEDURE PROC (L : LIM) IS + I : INTEGER; + BEGIN + I := IDENT_INT (L.D); + END PROC; + + BEGIN + PROC (LIM3 (L)); + FAILED ( "NO EXCEPTION RAISED FOR 'LIM3 (L)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'LIM3 (L)'" ); + END; + + RESULT; +END C46053A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c46054a.ada b/gcc/testsuite/ada/acats/tests/c4/c46054a.ada new file mode 100644 index 000000000..f87cfa4f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46054a.ada @@ -0,0 +1,191 @@ +-- C46054A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR CONVERSION TO AN +-- ACCESS SUBTYPE IF THE OPERAND VALUE IS NOT NULL AND THE +-- DISCRIMINANTS OR INDEX BOUNDS OF THE DESIGNATED OBJECT DO NOT +-- MATCH THOSE OF THE TARGET TYPE. + +-- R.WILLIAMS 9/9/86 + +WITH REPORT; USE REPORT; +PROCEDURE C46054A IS + +BEGIN + TEST ( "C46054A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & + "CONVERSION TO AN ACCESS SUBTYPE IF THE " & + "OPERAND VALUE IS NOT NULL AND THE " & + "DISCRIMINANTS OR INDEX BOUNDS OF THE " & + "DESIGNATED OBJECT DO NOT MATCH THOSE OF " & + "THE TARGET TYPE" ); + + DECLARE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACREC IS ACCESS REC; + A : ACREC (IDENT_INT (0)) := NEW REC (IDENT_INT (0)); + + SUBTYPE ACREC3 IS ACREC (IDENT_INT (3)); + + PROCEDURE PROC (A : ACREC) IS + I : INTEGER; + BEGIN + I := IDENT_INT (A.D); + END PROC; + + BEGIN + PROC (ACREC3 (A)); + FAILED ( "NO EXCEPTION RAISED FOR 'ACREC3 (A)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'ACREC3 (A)'" ); + END; + + DECLARE + TYPE REC (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACREC IS ACCESS REC; + + A : ACREC (IDENT_INT (3), IDENT_INT (1)) := + NEW REC (IDENT_INT (3), IDENT_INT (1)); + + SUBTYPE ACREC13 IS ACREC (IDENT_INT (1), IDENT_INT (3)); + + PROCEDURE PROC (A : ACREC) IS + I : INTEGER; + BEGIN + I := IDENT_INT (A.D1); + END PROC; + + BEGIN + PROC (ACREC13 (A)); + FAILED ( "NO EXCEPTION RAISED FOR 'ACREC13 (A)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'ACREC13 (A)'" ); + END; + + DECLARE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE ACARR IS ACCESS ARR; + A : ACARR (IDENT_INT (0) .. IDENT_INT (1)) := + NEW ARR'(IDENT_INT (0) .. IDENT_INT (1) => 0); + + SUBTYPE ACARR02 IS ACARR (IDENT_INT (0) .. IDENT_INT (2)); + + PROCEDURE PROC (A : ACARR) IS + I : INTEGER; + BEGIN + I := IDENT_INT (A'LAST); + END PROC; + + BEGIN + PROC (ACARR02 (A)); + FAILED ( "NO EXCEPTION RAISED FOR 'ACARR02 (A)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'ACARR02 (A)'" ); + END; + + DECLARE + TYPE ARR IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + INTEGER; + + TYPE ACARR IS ACCESS ARR; + A : ACARR (IDENT_INT (1) .. IDENT_INT (0), + IDENT_INT (4) .. IDENT_INT (5)) := + NEW ARR'(IDENT_INT (1) .. IDENT_INT (0) => + (IDENT_INT (4) .. IDENT_INT (5) => 0)); + + SUBTYPE NACARR IS ACARR (IDENT_INT (0) .. IDENT_INT (1), + IDENT_INT (5) .. IDENT_INT (4)); + + PROCEDURE PROC (A : NACARR) IS + I : INTEGER; + BEGIN + I := IDENT_INT (A'LAST (1)); + END PROC; + + BEGIN + PROC (NACARR (A)); + FAILED ( "NO EXCEPTION RAISED FOR 'NACARR (A)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'NACARR (A)'" ); + END; + + DECLARE + PACKAGE PKG1 IS + TYPE PRIV (D : INTEGER) IS PRIVATE; + TYPE ACPRV IS ACCESS PRIV; + SUBTYPE ACPRV3 IS ACPRV (IDENT_INT (3)); + + PRIVATE + TYPE PRIV (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG1; + + USE PKG1; + + PACKAGE PKG2 IS + A : ACPRV (IDENT_INT (0)) := NEW PRIV (IDENT_INT (0)); + END PKG2; + + USE PKG2; + + PROCEDURE PROC (A : ACPRV) IS + I : INTEGER; + BEGIN + I := IDENT_INT (A.D); + END PROC; + + BEGIN + PROC (ACPRV3 (A)); + FAILED ( "NO EXCEPTION RAISED FOR 'ACPRV3 (A)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'ACPRV3 (A)'" ); + END; + + RESULT; +END C46054A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460a01.a b/gcc/testsuite/ada/acats/tests/c4/c460a01.a new file mode 100644 index 000000000..2d583706e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460a01.a @@ -0,0 +1,408 @@ +-- C460A01.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 if the target type of a type conversion is a general +-- access type, Program_Error is raised if the accessibility level of +-- the operand type is deeper than that of the target type. Check for +-- cases where the type conversion occurs in an instance body, and +-- the operand type is passed as an actual during instantiation. +-- +-- TEST DESCRIPTION: +-- In order to satisfy accessibility requirements, the operand type must +-- be at the same or a less deep nesting level than the target type -- the +-- operand type must "live" as long as the target type. Nesting levels +-- are the run-time nestings of masters: block statements; subprogram, +-- task, and entry bodies; and accept statements. Packages are invisible +-- to accessibility rules. +-- +-- This test checks for cases where the operand is a subprogram formal +-- parameter. +-- +-- The test declares three generic packages, each containing an access +-- type conversion in which the operand type is a formal type: +-- +-- (1) One in which the target type is declared within the +-- specification, and the conversion occurs within a nested +-- function. +-- +-- (2) One in which the target type is also a formal type, and +-- the conversion occurs within a nested function. +-- +-- (3) One in which the target type is declared outside the +-- generic, and the conversion occurs within a nested +-- procedure. +-- +-- The test verifies the following: +-- +-- For (1), Program_Error is not raised when the nested function is +-- called. Since the actual corresponding to the formal operand type +-- must always have the same or a less deep level than the target +-- type declared within the instance, the access type conversion is +-- always safe. +-- +-- For (2), Program_Error is raised when the nested function is +-- called if the operand type passed as an actual during instantiation +-- has an accessibility level deeper than that of the target type +-- passed as an actual, and that no exception is raised otherwise. +-- The exception is propagated to the innermost enclosing master. +-- +-- For (3), Program_Error is raised when the nested procedure is +-- called if the operand type passed as an actual during instantiation +-- has an accessibility level deeper than that of the target type. +-- The exception is handled within the nested procedure. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F460A00.A +-- => C460A01.A +-- +-- +-- CHANGE HISTORY: +-- 09 May 95 SAIC Initial prerelease version. +-- 24 Apr 96 SAIC Added code to avoid dead variable optimization. +-- 13 Feb 97 PWB.CTA Removed 'Class from qual expression at line 342. +--! + +generic + type Designated_Type is tagged private; + type Operand_Type is access Designated_Type; +package C460A01_0 is + type Target_Type is access all Designated_Type; + function Convert (P : Operand_Type) return Target_Type; +end C460A01_0; + + + --==================================================================-- + + +package body C460A01_0 is + function Convert (P : Operand_Type) return Target_Type is + begin + return Target_Type(P); -- Never fails. + end Convert; +end C460A01_0; + + + --==================================================================-- + + +generic + type Designated_Type is tagged private; + type Operand_Type is access all Designated_Type; + type Target_Type is access all Designated_Type; +package C460A01_1 is + function Convert (P : Operand_Type) return Target_Type; +end C460A01_1; + + + --==================================================================-- + + +package body C460A01_1 is + function Convert (P : Operand_Type) return Target_Type is + begin + return Target_Type(P); + end Convert; +end C460A01_1; + + + --==================================================================-- + + +with F460A00; +generic + type Designated_Type (<>) is new F460A00.Tagged_Type with private; + type Operand_Type is access Designated_Type; +package C460A01_2 is + procedure Proc (P : Operand_Type; + Res : out F460A00.TC_Result_Kind); +end C460A01_2; + + + --==================================================================-- + +with Report; +package body C460A01_2 is + procedure Proc (P : Operand_Type; + Res : out F460A00.TC_Result_Kind) is + Ptr : F460A00.AccTag_L0; + begin + Ptr := F460A00.AccTag_L0(P); + + -- Avoid optimization (dead variable removal of Ptr): + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in C460A01_2 instance"); + end if; + + Res := F460A00.OK; + exception + when Program_Error => Res := F460A00.PE_Exception; + when others => Res := F460A00.Others_Exception; + end Proc; +end C460A01_2; + + + --==================================================================-- + + +with F460A00; +with C460A01_0; +with C460A01_1; +with C460A01_2; + +with Report; +procedure C460A01 is +begin -- C460A01. -- [ Level = 1 ] + + Report.Test ("C460A01", "Run-time accessibility checks: instance " & + "bodies. Operand type of access type conversion is " & + "passed as actual to instance"); + + + SUBTEST1: + declare -- [ Level = 2 ] + type AccTag_L2 is access all F460A00.Tagged_Type; + Operand: AccTag_L2 := new F460A00.Tagged_Type; + + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST1. + + declare -- [ Level = 3 ] + -- The instantiation of C460A01_0 should NOT result in any + -- exceptions. + + package Pack_OK is new C460A01_0 (F460A00.Tagged_Type, AccTag_L2); + Target : Pack_OK.Target_Type; + begin + -- The accessibility level of Pack_OK.Target_Type will always be at + -- least as deep as the operand type passed as an actual. Thus, + -- a call to Pack_OK.Convert does not propagate an exception: + + Target := Pack_OK.Convert(Operand); + + -- Avoid optimization (dead variable removal of Target): + if not Report.Equal (Target.C, Target.C) then -- Always false. + Report.Failed ("Unexpected error in SUBTEST #1"); + end if; + + Result := F460A00.OK; -- Expected result. + exception + when Program_Error => Result := F460A00.PE_Exception; + when others => Result := F460A00.Others_Exception; + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #1: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #1: Unexpected exception raised"); + end SUBTEST1; + + + + SUBTEST2: + declare -- [ Level = 2 ] + type AccTag_L2 is access all F460A00.Tagged_Type; + Operand : AccTag_L2 := new F460A00.Tagged_Type; + + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST2. + + declare -- [ Level = 3 ] + + type AccTag_L3 is access all F460A00.Tagged_Type; + Target : AccTag_L3; + + -- The instantiation of C460A01_1 should NOT result in any + -- exceptions. + + package Pack_OK is new C460A01_1 + (Designated_Type => F460A00.Tagged_Type, + Operand_Type => AccTag_L2, + Target_Type => AccTag_L3); + begin + -- The accessibility level of the actual passed as the operand type + -- in Pack_OK is 2. The accessibility level of the actual passed as + -- the target type is 3. Therefore, the access type conversion in + -- Pack_OK.Convert does not raise an exception when the subprogram is + -- called. If an exception is (incorrectly) raised, it is propagated + -- to the innermost enclosing master: + + Target := Pack_OK.Convert(Operand); + + -- Avoid optimization (dead variable removal of Target): + if not Report.Equal (Target.C, Target.C) then -- Always false. + Report.Failed ("Unexpected error in SUBTEST #2"); + end if; + + Result := F460A00.OK; -- Expected result. + exception + when Program_Error => Result := F460A00.PE_Exception; + when others => Result := F460A00.Others_Exception; + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #2"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #2: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #2: Unexpected exception raised"); + end SUBTEST2; + + + + SUBTEST3: + declare -- [ Level = 2 ] + type AccTag_L2 is access all F460A00.Tagged_Type; + Target : AccTag_L2; + + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST3. + + declare -- [ Level = 3 ] + + type AccTag_L3 is access all F460A00.Tagged_Type; + Operand : AccTag_L3 := new F460A00.Tagged_Type; + + -- The instantiation of C460A01_1 should NOT result in any + -- exceptions. + + package Pack_PE is new C460A01_1 + (Designated_Type => F460A00.Tagged_Type, + Operand_Type => AccTag_L3, + Target_Type => AccTag_L2); + begin + -- The accessibility level of the actual passed as the operand type + -- in Pack_PE is 3. The accessibility level of the actual passed as + -- the target type is 2. Therefore, the access type conversion in + -- Pack_PE.Convert raises Program_Error when the subprogram is + -- called. The exception is propagated to the innermost enclosing + -- master: + + Target := Pack_PE.Convert(Operand); + + -- Avoid optimization (dead variable removal of Target): + if not Report.Equal (Target.C, Target.C) then -- Always false. + Report.Failed ("Unexpected error in SUBTEST #3"); + end if; + + Result := F460A00.OK; + exception + when Program_Error => Result := F460A00.PE_Exception; + -- Expected result. + when others => Result := F460A00.Others_Exception; + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #3"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #3: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #3: Unexpected exception raised"); + end SUBTEST3; + + + + SUBTEST4: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST4. + + declare -- [ Level = 3 ] + + TType : F460A00.Tagged_Type; + Operand : F460A00.AccTagClass_L0 + := new F460A00.Tagged_Type'(TType); + + -- The instantiation of C460A01_2 should NOT result in any + -- exceptions. + + package Pack_OK is new C460A01_2 (F460A00.Tagged_Type'Class, + F460A00.AccTagClass_L0); + begin + -- The accessibility level of the actual passed as the operand type + -- in Pack_OK is 0. The accessibility level of the target type + -- (F460A00.AccTag_L0) is also 0. Therefore, the access type + -- conversion in Pack_OK.Proc does not raise an exception when the + -- subprogram is called. If an exception is (incorrectly) raised, + -- it is handled within the subprogram: + + Pack_OK.Proc(Operand, Result); + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #4"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #4: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #4: Unexpected exception raised"); + end SUBTEST4; + + + + SUBTEST5: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST5. + + declare -- [ Level = 3 ] + + type AccDerTag_L3 is access all F460A00.Derived_Tagged_Type; + Operand : AccDerTag_L3 := new F460A00.Derived_Tagged_Type; + + -- The instantiation of C460A01_2 should NOT result in any + -- exceptions. + + package Pack_PE is new C460A01_2 (F460A00.Derived_Tagged_Type, + AccDerTag_L3); + begin + -- The accessibility level of the actual passed as the operand type + -- in Pack_PE is 3. The accessibility level of the target type + -- (F460A00.AccTag_L0) is 0. Therefore, the access type conversion + -- in Pack_PE.Proc raises Program_Error when the subprogram is + -- called. The exception is handled within the subprogram: + + Pack_PE.Proc(Operand, Result); + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #5"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #5: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #5: Unexpected exception raised"); + end SUBTEST5; + + Report.Result; + +end C460A01; diff --git a/gcc/testsuite/ada/acats/tests/c4/c460a02.a b/gcc/testsuite/ada/acats/tests/c4/c460a02.a new file mode 100644 index 000000000..1d79d3a61 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460a02.a @@ -0,0 +1,413 @@ +-- C460A02.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 if the target type of a type conversion is a general +-- access type, Program_Error is raised if the accessibility level of +-- the operand type is deeper than that of the target type. Check for +-- cases where the type conversion occurs in an instance body, and +-- the operand type is declared inside the instance or is the anonymous +-- access type of an access parameter or access discriminant. +-- +-- TEST DESCRIPTION: +-- In order to satisfy accessibility requirements, the operand type must +-- be at the same or a less deep nesting level than the target type -- the +-- operand type must "live" as long as the target type. Nesting levels +-- are the run-time nestings of masters: block statements; subprogram, +-- task, and entry bodies; and accept statements. Packages are invisible +-- to accessibility rules. +-- +-- This test checks for cases where the operand is a component of a +-- generic formal object, a stand-alone object, and an access parameter. +-- +-- The test declares three generic units, each containing an access +-- type conversion in which the target type is a formal type: +-- +-- (1) A generic package in which the operand type is the anonymous +-- access type of an access discriminant, and the conversion +-- occurs within the declarative part of the body. +-- +-- (2) A generic package in which the operand type is declared within +-- the specification, and the conversion occurs within the +-- sequence of statements of the body. +-- +-- (3) A generic procedure in which the operand type is the anonymous +-- access type of an access parameter, and the conversion occurs +-- within the sequence of statements. +-- +-- The test verifies the following: +-- +-- For (1), Program_Error is raised when the package is instantiated +-- if the actual passed through the formal object has an accessibility +-- level deeper than that of the target type passed as an actual, and +-- that no exception is raised otherwise. The exception is propagated +-- to the innermost enclosing master. +-- +-- For (2), Program_Error is raised when the package is instantiated +-- if the package is instantiated at a level deeper than that of the +-- target type passed as an actual, and that no exception is raised +-- otherwise. The exception is handled within the package body. +-- +-- For (3), Program_Error is raised when the instance procedure is +-- called if the actual passed through the access parameter has an +-- accessibility level deeper than that of the target type passed as +-- an actual, and that no exception is raised otherwise. The exception +-- is handled within the instance procedure. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F460A00.A +-- => C460A02.A +-- +-- +-- CHANGE HISTORY: +-- 10 May 95 SAIC Initial prerelease version. +-- 24 Apr 96 SAIC Changed the target type formal to be +-- access-to-constant; Modified code to avoid dead +-- variable optimization. +-- +--! + +with F460A00; +generic + type Target_Type is access all F460A00.Tagged_Type; + FObj: in out F460A00.Composite_Type; +package C460A02_0 is + procedure Dummy; -- Needed to allow package body. +end C460A02_0; + + + --==================================================================-- + +with Report; +package body C460A02_0 is + Ptr: Target_Type := Target_Type(FObj.D); + + procedure Dummy is + begin + null; + end Dummy; + +begin + -- Avoid optimization (dead variable removal of Ptr): + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in C460A02_0 instance"); + end if; + +end C460A02_0; + + + --==================================================================-- + + +with F460A00; +generic + type Designated_Type is private; + type Target_Type is access all Designated_Type; + FObj : in out Target_Type; + FRes : in out F460A00.TC_Result_Kind; +package C460A02_1 is + type Operand_Type is access Designated_Type; + Ptr : Operand_Type := new Designated_Type; + + procedure Dummy; -- Needed to allow package body. +end C460A02_1; + + + --==================================================================-- + + +package body C460A02_1 is + procedure Dummy is + begin + null; + end Dummy; +begin + FRes := F460A00.UN_Init; + FObj := Target_Type(Ptr); + FRes := F460A00.OK; +exception + when Program_Error => FRes := F460A00.PE_Exception; + when others => FRes := F460A00.Others_Exception; +end C460A02_1; + + + --==================================================================-- + + +with F460A00; +generic + type Designated_Type is new F460A00.Tagged_Type with private; + type Target_Type is access constant Designated_Type; +procedure C460A02_2 (P : access Designated_Type'Class; + Res : out F460A00.TC_Result_Kind); + + + --==================================================================-- + + +with Report; +procedure C460A02_2 (P : access Designated_Type'Class; + Res : out F460A00.TC_Result_Kind) is + Ptr : Target_Type; +begin + Res := F460A00.UN_Init; + Ptr := Target_Type(P); + + -- Avoid optimization (dead variable removal of Ptr): + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in C460A02_2 instance"); + end if; + Res := F460A00.OK; +exception + when Program_Error => Res := F460A00.PE_Exception; + when others => Res := F460A00.Others_Exception; +end C460A02_2; + + + --==================================================================-- + + +with F460A00; +with C460A02_0; +with C460A02_1; +with C460A02_2; + +with Report; +procedure C460A02 is +begin -- C460A02. -- [ Level = 1 ] + + Report.Test ("C460A02", "Run-time accessibility checks: instance " & + "bodies. Operand type of access type conversion is " & + "declared inside instance or is anonymous"); + + + SUBTEST1: + declare -- [ Level = 2 ] + type AccTag_L2 is access all F460A00.Tagged_Type; + PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type; + Operand_L2 : F460A00.Composite_Type(PTag_L2); + + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST1. + + begin -- [ Level = 3 ] + declare -- [ Level = 4 ] + -- The accessibility level of the actual passed as the target type + -- in Pack_OK is 2. The accessibility level of the composite actual + -- (and thus, the level of the anonymous type of the access + -- discriminant, which is the same as that of the containing + -- object) is also 2. Therefore, the access type conversion in + -- Pack_OK does not raise an exception upon instantiation: + + package Pack_OK is new C460A02_0 + (Target_Type => AccTag_L2, FObj => Operand_L2); + begin + Result := F460A00.OK; -- Expected result. + end; + exception + when Program_Error => Result := F460A00.PE_Exception; + when others => Result := F460A00.Others_Exception; + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1"); + + end SUBTEST1; + + + + SUBTEST2: + declare -- [ Level = 2 ] + type AccTag_L2 is access all F460A00.Tagged_Type; + PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type; + + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST2. + + declare -- [ Level = 3 ] + Operand_L3 : F460A00.Composite_Type(PTag_L2); + begin + declare -- [ Level = 4 ] + -- The accessibility level of the actual passed as the target type + -- in Pack_PE is 2. The accessibility level of the composite actual + -- (and thus, the level of the anonymous type of the access + -- discriminant, which is the same as that of the containing + -- object) is 3. Therefore, the access type conversion in Pack_PE + -- propagates Program_Error upon instantiation: + + package Pack_PE is new C460A02_0 (AccTag_L2, Operand_L3); + begin + Result := F460A00.OK; + end; + exception + when Program_Error => Result := F460A00.PE_Exception; + -- Expected result. + when others => Result := F460A00.Others_Exception; + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #2"); + + end SUBTEST2; + + + + SUBTEST3: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST3. + + declare -- [ Level = 3 ] + type AccArr_L3 is access all F460A00.Array_Type; + Target: AccArr_L3; + + -- The accessibility level of the actual passed as the target type + -- in Pack_OK is 3. The accessibility level of the operand type is + -- that of the instance, which is also 3. Therefore, the access type + -- conversion in Pack_OK does not raise an exception upon + -- instantiation. If an exception is (incorrectly) raised, it is + -- handled within the instance: + + package Pack_OK is new C460A02_1 + (Designated_Type => F460A00.Array_Type, + Target_Type => AccArr_L3, + FObj => Target, + FRes => Result); + begin + null; + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #3"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #3: Program_Error incorrectly propagated"); + when others => + Report.Failed ("SUBTEST #3: Unexpected exception propagated"); + end SUBTEST3; + + + + SUBTEST4: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST4. + + declare -- [ Level = 3 ] + Target: F460A00.AccArr_L0; + + -- The accessibility level of the actual passed as the target type + -- in Pack_PE is 0. The accessibility level of the operand type is + -- that of the instance, which is 3. Therefore, the access type + -- conversion in Pack_PE raises Program_Error upon instantiation. + -- The exception is handled within the instance: + + package Pack_PE is new C460A02_1 + (Designated_Type => F460A00.Array_Type, + Target_Type => F460A00.AccArr_L0, + FObj => Target, + FRes => Result); + begin + null; + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #4"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #4: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #4: Unexpected exception raised"); + end SUBTEST4; + + + + SUBTEST5: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST5. + + declare -- [ Level = 3 ] + -- The instantiation of C460A02_2 should NOT result in any + -- exceptions. + + procedure Proc is new C460A02_2 (F460A00.Tagged_Type, + F460A00.AccTag_L0); + begin + -- The accessibility level of the actual passed to Proc is 0. The + -- accessibility level of the actual passed as the target type is + -- also 0. Therefore, the access type conversion in Proc does not + -- raise an exception when the subprogram is called. If an exception + -- is (incorrectly) raised, it is handled within the subprogram: + + Proc (F460A00.PTagClass_L0, Result); + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #5"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #5: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #5: Unexpected exception raised"); + end SUBTEST5; + + + + SUBTEST6: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST6. + + declare -- [ Level = 3 ] + -- The instantiation of C460A02_2 should NOT result in any + -- exceptions. + + procedure Proc is new C460A02_2 (F460A00.Tagged_Type, + F460A00.AccTag_L0); + begin + -- In the call to (instantiated) procedure Proc, the first actual + -- parameter is an allocator. Its accessibility level is that of + -- the level of execution of Proc, which is 3. The accessibility + -- level of the actual passed as the target type is 0. Therefore, + -- the access type conversion in Proc raises Program_Error when the + -- subprogram is called. The exception is handled within the + -- subprogram: + + Proc (new F460A00.Tagged_Type, Result); + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #6"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #6: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #6: Unexpected exception raised"); + end SUBTEST6; + + Report.Result; + +end C460A02; diff --git a/gcc/testsuite/ada/acats/tests/c4/c47002a.ada b/gcc/testsuite/ada/acats/tests/c4/c47002a.ada new file mode 100644 index 000000000..e86498da0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47002a.ada @@ -0,0 +1,107 @@ +-- C47002A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS +-- THE OPERANDS OF QUALIFIED EXPRESSIONS. +-- THIS TEST IS FOR DISCRETE TYPES. + +-- RJW 7/23/86 + +WITH REPORT; USE REPORT; +PROCEDURE C47002A IS + +BEGIN + + TEST( "C47002A", "CHECK THAT VALUES HAVING DISCRETE TYPES " & + "CAN BE WRITTEN AS THE OPERANDS OF " & + "QUALIFIED EXPRESSIONS" ); + + DECLARE -- ENUMERATION TYPES. + + TYPE WEEK IS (SUN, MON, TUE, WED, THU, FRI, SAT); + TYPE WEEKEND IS (SAT, SUN); + + TYPE CHAR IS ('B', 'A'); + + TYPE MYBOOL IS (TRUE, FALSE); + + TYPE NBOOL IS NEW BOOLEAN; + + BEGIN + IF WEEKEND'(SAT) >= SUN THEN + FAILED ( "INCORRECT RESULTS FOR TYPE WEEKEND" ); + END IF; + + IF CHAR'('B') >= 'A' THEN + FAILED ( "INCORRECT RESULTS FOR TYPE CHAR" ); + END IF; + + IF MYBOOL'(TRUE) >= FALSE THEN + FAILED ( "INCORRECT RESULTS FOR TYPE MYBOOL" ); + END IF; + + IF NBOOL'(TRUE) <= FALSE THEN + FAILED ( "INCORRECT RESULTS FOR TYPE NBOOL" ); + END IF; + END; + + DECLARE -- INTEGER TYPES. + + TYPE RESULTS IS (INT1, INT2, INT3); + + TYPE NEWINT IS NEW INTEGER; + + TYPE INT IS RANGE -10 .. 10; + + FUNCTION F (I : NEWINT) RETURN RESULTS IS + BEGIN + RETURN INT1; + END F; + + FUNCTION F (I : INT) RETURN RESULTS IS + BEGIN + RETURN INT2; + END F; + + FUNCTION F (I : INTEGER) RETURN RESULTS IS + BEGIN + RETURN INT3; + END F; + + BEGIN + IF F (NEWINT'(5)) /= INT1 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE NEWINT" ); + END IF; + + IF F (INT'(5)) /= INT2 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE INT" ); + END IF; + + IF F (INTEGER'(5)) /= INT3 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE INTEGER" ); + END IF; + END; + + RESULT; +END C47002A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c47002b.ada b/gcc/testsuite/ada/acats/tests/c4/c47002b.ada new file mode 100644 index 000000000..ffa7b96dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47002b.ada @@ -0,0 +1,115 @@ +-- C47002B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS +-- THE OPERANDS OF QUALIFIED EXPRESSIONS. +-- THIS TEST IS FOR REAL TYPES. + +-- RJW 7/23/86 + +WITH REPORT; USE REPORT; +PROCEDURE C47002B IS + +BEGIN + + TEST( "C47002B", "CHECK THAT VALUES HAVING REAL TYPES " & + "CAN BE WRITTEN AS THE OPERANDS OF " & + "QUALIFIED EXPRESSIONS" ); + + DECLARE -- FLOATING POINT TYPES. + + TYPE RESULTS IS (FL1, FL2, FL3); + + TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0; + + TYPE NFLT IS NEW FLOAT; + + FUNCTION F (FL : FLT) RETURN RESULTS IS + BEGIN + RETURN FL1; + END F; + + FUNCTION F (FL : NFLT) RETURN RESULTS IS + BEGIN + RETURN FL2; + END F; + + FUNCTION F (FL : FLOAT) RETURN RESULTS IS + BEGIN + RETURN FL3; + END F; + + BEGIN + IF F (FLT'(0.0)) /= FL1 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE FLT" ); + END IF; + + IF F (NFLT'(0.0)) /= FL2 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE NFLT" ); + END IF; + + IF F (FLOAT'(0.0)) /= FL3 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE FLOAT" ); + END IF; + END; + + DECLARE -- FIXED POINT TYPES. + + TYPE RESULTS IS (FI1, FI2, FI3); + + TYPE FIXED IS DELTA 0.5 RANGE -5.0 .. 5.0; + + TYPE NFIX IS NEW FIXED; + + FUNCTION F (FI : FIXED) RETURN RESULTS IS + BEGIN + RETURN FI1; + END F; + + FUNCTION F (FI : NFIX) RETURN RESULTS IS + BEGIN + RETURN FI2; + END F; + + FUNCTION F (FI : DURATION) RETURN RESULTS IS + BEGIN + RETURN FI3; + END F; + + BEGIN + IF F (FIXED'(0.0)) /= FI1 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE FIXED" ); + END IF; + + IF F (NFIX'(0.0)) /= FI2 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE NFIX" ); + END IF; + + IF F (DURATION'(0.0)) /= FI3 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE DURATION" ); + END IF; + END; + + RESULT; +END C47002B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c47002c.ada b/gcc/testsuite/ada/acats/tests/c4/c47002c.ada new file mode 100644 index 000000000..b9327e93b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47002c.ada @@ -0,0 +1,212 @@ +-- C47002C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS +-- THE OPERANDS OF QUALIFIED EXPRESSIONS. +-- THIS TEST IS FOR ARRAY, RECORD, AND ACCESS TYPES. + +-- RJW 7/23/86 + +WITH REPORT; USE REPORT; +PROCEDURE C47002C IS + +BEGIN + + TEST( "C47002C", "CHECK THAT VALUES HAVING ARRAY, RECORD, AND " & + "ACCESS TYPES CAN BE WRITTEN AS THE OPERANDS " & + "OF QUALIFIED EXPRESSIONS" ); + + DECLARE -- ARRAY TYPES. + + TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE ARR1 IS ARR (1 .. 1); + SUBTYPE ARR5 IS ARR (1 .. 5); + + TYPE NARR IS NEW ARR; + SUBTYPE NARR2 IS NARR (2 .. 2); + + TYPE TARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) + OF INTEGER; + SUBTYPE TARR15 IS TARR (1 .. 1, 1 .. 5); + SUBTYPE TARR51 IS TARR (1 .. 5, 1 .. 1); + + TYPE NTARR IS NEW TARR; + SUBTYPE NTARR26 IS NTARR (2 .. 6, 2 .. 6); + + FUNCTION F (X : ARR) RETURN ARR IS + BEGIN + RETURN X; + END; + + FUNCTION F (X : NARR) RETURN NARR IS + BEGIN + RETURN X; + END; + + FUNCTION F (X : TARR) RETURN TARR IS + BEGIN + RETURN X; + END; + + FUNCTION F (X : NTARR) RETURN NTARR IS + BEGIN + RETURN X; + END; + + BEGIN + IF F (ARR1'(OTHERS => 0))'LAST /= 1 THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE ARR1" ); + END IF; + + IF F (ARR5'(OTHERS => 0))'LAST /= 5 THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE ARR5" ); + END IF; + + IF F (NARR2'(OTHERS => 0))'FIRST /= 2 OR + F (NARR2'(OTHERS => 0))'LAST /= 2 THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE NARR2" ); + END IF; + + IF F (TARR15'(OTHERS => (OTHERS => 0)))'LAST /= 1 OR + F (TARR15'(OTHERS => (OTHERS => 0)))'LAST (2) /= 5 THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE TARR15" ); + END IF; + + IF F (TARR51'(OTHERS => (OTHERS => 0)))'LAST /= 5 OR + F (TARR51'(OTHERS => (OTHERS => 0)))'LAST (2) /= 1 THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE TARR51" ); + END IF; + + IF F (NTARR26'(OTHERS => (OTHERS => 0)))'FIRST /= 2 OR + F (NTARR26'(OTHERS => (OTHERS => 0)))'LAST /= 6 OR + F (NTARR26'(OTHERS => (OTHERS => 0)))'FIRST (2) /= 2 OR + F (NTARR26'(OTHERS => (OTHERS => 0)))'LAST (2) /= 6 THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE NTARR26" ); + END IF; + + END; + + DECLARE -- RECORD TYPES. + + TYPE GENDER IS (MALE, FEMALE, NEUTER); + + TYPE MAN IS + RECORD + AGE : POSITIVE; + END RECORD; + + TYPE WOMAN IS + RECORD + AGE : POSITIVE; + END RECORD; + + TYPE ANDROID IS NEW MAN; + + FUNCTION F (X: WOMAN) RETURN GENDER IS + BEGIN + RETURN FEMALE; + END F; + + FUNCTION F (X: MAN) RETURN GENDER IS + BEGIN + RETURN MALE; + END F; + + FUNCTION F (X : ANDROID) RETURN GENDER IS + BEGIN + RETURN NEUTER; + END F; + + BEGIN + IF F (MAN'(AGE => 23)) /= MALE THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE MAN" ); + END IF; + + IF F (WOMAN'(AGE => 38)) /= FEMALE THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE WOMAN" ); + END IF; + + IF F (ANDROID'(AGE => 2001)) /= NEUTER THEN + FAILED ( "INCORRECT RESULTS FOR TYPE ANDRIOD" ); + END IF; + END; + + DECLARE -- ACCESS TYPES. + + TYPE CODE IS (OLD, BRANDNEW, WRECK); + + TYPE CAR (D : CODE) IS + RECORD + NULL; + END RECORD; + + TYPE KEY IS ACCESS CAR; + + TYPE KEY_OLD IS ACCESS CAR (OLD); + KO : KEY_OLD := NEW CAR'(D => OLD); + + TYPE KEY_WRECK IS ACCESS CAR (WRECK); + + TYPE KEY_CARD IS NEW KEY; + KC : KEY_CARD := NEW CAR'(D => BRANDNEW); + + FUNCTION F (X : KEY_OLD) RETURN CODE IS + BEGIN + RETURN OLD; + END F; + + FUNCTION F (X : KEY_WRECK) RETURN CODE IS + BEGIN + RETURN WRECK; + END F; + + FUNCTION F (X : KEY_CARD) RETURN CODE IS + BEGIN + RETURN BRANDNEW; + END F; + BEGIN + IF KEY_OLD'(KO) /= KO THEN + FAILED ( "INCORRECT RESULTS FOR TYPE KEY_OLD - 1" ); + END IF; + + IF KEY_CARD'(KC) /= KC THEN + FAILED ( "INCORRECT RESULTS FOR TYPE KEY_CARD - 1" ); + END IF; + + + IF F (KEY_OLD'(NULL)) /= OLD THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE KEY_OLD - 2" ); + END IF; + + IF F (KEY_WRECK'(NULL)) /= WRECK THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE KEY_WRECK" ); + END IF; + + IF F (KEY_CARD'(NULL)) /= BRANDNEW THEN + FAILED ( "INCORRECT RESULTS FOR TYPE KEY_CARD - 2" ); + END IF; + END; + + RESULT; +END C47002C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c47002d.ada b/gcc/testsuite/ada/acats/tests/c4/c47002d.ada new file mode 100644 index 000000000..472c20072 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47002d.ada @@ -0,0 +1,273 @@ +-- C47002D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS +-- THE OPERANDS OF QUALIFIED EXPRESSIONS. +-- THIS TEST IS FOR PRIVATE AND LIMITED PRIVATE TYPES. + +-- RJW 7/23/86 + +WITH REPORT; USE REPORT; +PROCEDURE C47002D IS + +BEGIN + + TEST( "C47002D", "CHECK THAT VALUES HAVING PRIVATE AND LIMITED " & + "PRIVATE TYPES CAN BE WRITTEN AS THE OPERANDS " & + "OF QUALIFIED EXPRESSIONS" ); + + DECLARE -- PRIVATE TYPES. + + TYPE RESULTS IS (P1, P2, P3, P4, P5); + + PACKAGE PKG1 IS + TYPE PINT IS PRIVATE; + TYPE PCHAR IS PRIVATE; + TYPE PARR IS PRIVATE; + TYPE PREC (D : INTEGER) IS PRIVATE; + TYPE PACC IS PRIVATE; + + FUNCTION F RETURN PINT; + FUNCTION F RETURN PCHAR; + FUNCTION F RETURN PARR; + FUNCTION F RETURN PREC; + FUNCTION F RETURN PACC; + + PRIVATE + TYPE PINT IS NEW INTEGER; + TYPE PCHAR IS NEW CHARACTER; + TYPE PARR IS ARRAY (1 .. 2) OF NATURAL; + + TYPE PREC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE PACC IS ACCESS PREC; + + END PKG1; + + PACKAGE BODY PKG1 IS + FUNCTION F RETURN PINT IS + BEGIN + RETURN 1; + END F; + + FUNCTION F RETURN PCHAR IS + BEGIN + RETURN 'B'; + END F; + + FUNCTION F RETURN PARR IS + BEGIN + RETURN PARR'(OTHERS => 3); + END F; + + FUNCTION F RETURN PREC IS + BEGIN + RETURN PREC'(D => 4); + END F; + + FUNCTION F RETURN PACC IS + BEGIN + RETURN NEW PREC'(F); + END F; + + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + FUNCTION CHECK (P : PINT) RETURN RESULTS IS + BEGIN + RETURN P1; + END CHECK; + + FUNCTION CHECK (P : PCHAR) RETURN RESULTS IS + BEGIN + RETURN P2; + END CHECK; + + FUNCTION CHECK (P : PARR) RETURN RESULTS IS + BEGIN + RETURN P3; + END CHECK; + + FUNCTION CHECK (P : PREC) RETURN RESULTS IS + BEGIN + RETURN P4; + END CHECK; + + FUNCTION CHECK (P : PACC) RETURN RESULTS IS + BEGIN + RETURN P5; + END CHECK; + + BEGIN + IF CHECK (PINT'(F)) /= P1 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE PINT" ); + END IF; + + IF CHECK (PCHAR'(F)) /= P2 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE PCHAR" ); + END IF; + + IF CHECK (PARR'(F)) /= P3 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE PARR" ); + END IF; + + IF CHECK (PREC'(F)) /= P4 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE PREC" ); + END IF; + + IF CHECK (PACC'(F)) /= P5 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE PACC" ); + END IF; + + END PKG2; + + BEGIN + NULL; + END; + + DECLARE -- LIMITED PRIVATE TYPES. + + TYPE RESULTS IS (LP1, LP2, LP3, LP4, LP5); + + PACKAGE PKG1 IS + TYPE LPINT IS LIMITED PRIVATE; + TYPE LPCHAR IS LIMITED PRIVATE; + TYPE LPARR IS LIMITED PRIVATE; + TYPE LPREC (D : INTEGER) IS LIMITED PRIVATE; + TYPE LPACC IS LIMITED PRIVATE; + + FUNCTION F RETURN LPINT; + FUNCTION F RETURN LPCHAR; + FUNCTION F RETURN LPARR; + FUNCTION F RETURN LPREC; + FUNCTION F RETURN LPACC; + + PRIVATE + TYPE LPINT IS NEW INTEGER; + TYPE LPCHAR IS NEW CHARACTER; + TYPE LPARR IS ARRAY (1 .. 2) OF NATURAL; + + TYPE LPREC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE LPACC IS ACCESS LPREC; + + END PKG1; + + PACKAGE BODY PKG1 IS + FUNCTION F RETURN LPINT IS + BEGIN + RETURN 1; + END F; + + FUNCTION F RETURN LPCHAR IS + BEGIN + RETURN 'B'; + END F; + + FUNCTION F RETURN LPARR IS + BEGIN + RETURN LPARR'(OTHERS => 3); + END F; + + FUNCTION F RETURN LPREC IS + BEGIN + RETURN LPREC'(D => 4); + END F; + + FUNCTION F RETURN LPACC IS + BEGIN + RETURN NEW LPREC'(F); + END F; + + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + FUNCTION CHECK (LP : LPINT) RETURN RESULTS IS + BEGIN + RETURN LP1; + END CHECK; + + FUNCTION CHECK (LP : LPCHAR) RETURN RESULTS IS + BEGIN + RETURN LP2; + END CHECK; + + FUNCTION CHECK (LP : LPARR) RETURN RESULTS IS + BEGIN + RETURN LP3; + END CHECK; + + FUNCTION CHECK (LP : LPREC) RETURN RESULTS IS + BEGIN + RETURN LP4; + END CHECK; + + FUNCTION CHECK (LP : LPACC) RETURN RESULTS IS + BEGIN + RETURN LP5; + END CHECK; + + BEGIN + IF CHECK (LPINT'(F)) /= LP1 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE LPINT" ); + END IF; + + IF CHECK (LPCHAR'(F)) /= LP2 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE LPCHAR" ); + END IF; + + IF CHECK (LPARR'(F)) /= LP3 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE LPARR" ); + END IF; + + IF CHECK (LPREC'(F)) /= LP4 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE LPREC" ); + END IF; + + IF CHECK (LPACC'(F)) /= LP5 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE LPACC" ); + END IF; + + END PKG2; + + BEGIN + NULL; + END; + + RESULT; +END C47002D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c47003a.ada b/gcc/testsuite/ada/acats/tests/c4/c47003a.ada new file mode 100644 index 000000000..a3bd47a63 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47003a.ada @@ -0,0 +1,115 @@ +-- C47003A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES AN +-- ENUMERATION TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE +-- VALUE OF THE OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK. + +-- RJW 7/23/86 + +WITH REPORT; USE REPORT; +PROCEDURE C47003A IS + +BEGIN + + TEST( "C47003A", "WHEN THE TYPE MARK IN A QUALIFIED " & + "EXPRESSION DENOTES AN ENUMERATION " & + "TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "WHEN THE VALUE OF THE OPERAND DOES NOT LIE " & + "WITHIN THE RANGE OF THE TYPE MARK" ); + + DECLARE + + TYPE WEEK IS (SUN, MON, TUE, WED, THU, FRI, SAT); + SUBTYPE MIDWEEK IS WEEK RANGE TUE .. THU; + + FUNCTION IDENT (W : WEEK) RETURN WEEK IS + BEGIN + RETURN WEEK'VAL (IDENT_INT (WEEK'POS (W))); + END IDENT; + + BEGIN + IF MIDWEEK'(IDENT (SUN)) = TUE THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE MIDWEEK - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE MIDWEEK - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE MIDWEEK" ); + END; + + DECLARE + + SUBTYPE CHAR IS CHARACTER RANGE 'C' .. 'R'; + + BEGIN + IF CHAR'(IDENT_CHAR ('A')) = 'C' THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE CHAR - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE CHAR - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE CHAR" ); + END; + + DECLARE + + TYPE NBOOL IS NEW BOOLEAN; + SUBTYPE NFALSE IS NBOOL RANGE FALSE .. FALSE; + + FUNCTION IDENT (B : NBOOL) RETURN NBOOL IS + BEGIN + RETURN NBOOL (IDENT_BOOL (BOOLEAN (B))); + END IDENT; + + BEGIN + IF NFALSE'(IDENT (TRUE)) = FALSE THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE NFALSE - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE NFALSE - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE NFALSE" ); + END; + + RESULT; +END C47003A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c47004a.ada b/gcc/testsuite/ada/acats/tests/c4/c47004a.ada new file mode 100644 index 000000000..39659009d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47004a.ada @@ -0,0 +1,115 @@ +-- C47004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES AN INTEGER +-- TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE VALUE OF THE +-- OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK. + +-- RJW 7/23/86 + +WITH REPORT; USE REPORT; +PROCEDURE C47004A IS + +BEGIN + + TEST( "C47004A", "WHEN THE TYPE MARK IN A QUALIFIED " & + "EXPRESSION DENOTES AN INTEGER " & + "TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "WHEN THE VALUE OF THE OPERAND DOES NOT LIE " & + "WITHIN THE RANGE OF THE TYPE MARK" ); + + DECLARE + + TYPE INT IS RANGE -10 .. 10; + SUBTYPE SINT IS INT RANGE -5 .. 5; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + RETURN INT (IDENT_INT (INTEGER (I))); + END; + + BEGIN + IF SINT'(IDENT (10)) = 5 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SINT - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SINT - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SINT" ); + END; + + DECLARE + + SUBTYPE SINTEGER IS INTEGER RANGE -10 .. 10; + + BEGIN + IF SINTEGER'(IDENT_INT (20)) = 15 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SINTEGER - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SINTEGER - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SINTEGER" ); + END; + + DECLARE + + TYPE NINTEGER IS NEW INTEGER; + SUBTYPE SNINT IS NINTEGER RANGE -10 .. 10; + + FUNCTION IDENT (I : NINTEGER) RETURN NINTEGER IS + BEGIN + RETURN NINTEGER (IDENT_INT (INTEGER (I))); + END; + + BEGIN + IF SNINT'(IDENT (-20)) = -10 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SNINT - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SNINT - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SNINT" ); + END; + + RESULT; +END C47004A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c47005a.ada b/gcc/testsuite/ada/acats/tests/c4/c47005a.ada new file mode 100644 index 000000000..f9ec93063 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47005a.ada @@ -0,0 +1,136 @@ +-- C47005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A FLOATING +-- POINT TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE VALUE +-- OF THE OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK. + +-- HISTORY: +-- RJW 07/23/86 CREATED ORIGINAL TEST. +-- BCB 08/19/87 CHANGED HEADER TO STANDARD HEADER FORMAT. ADDED +-- TEST FOR UPPER SIDE OF RANGE. + +WITH REPORT; USE REPORT; +PROCEDURE C47005A IS + +BEGIN + + TEST( "C47005A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " & + "DENOTES A FLOATING POINT TYPE, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED WHEN THE VALUE " & + "OF THE OPERAND DOES NOT LIE WITHIN THE " & + "RANGE OF THE TYPE MARK" ); + + DECLARE + + SUBTYPE SFLOAT IS FLOAT RANGE -1.0 .. 1.0; + + FUNCTION IDENT (F : FLOAT) RETURN FLOAT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN F; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + BEGIN + IF SFLOAT'(IDENT (-2.0)) = -1.0 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SFLOAT - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SFLOAT - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SFLOAT" ); + END; + + DECLARE + + TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0; + SUBTYPE SFLT IS FLT RANGE -1.0 .. 1.0; + + FUNCTION IDENT (F : FLT) RETURN FLT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN F; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + BEGIN + IF SFLT'(IDENT (-2.0)) = -1.0 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SFLT - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SFLT - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SFLT" ); + END; + + DECLARE + + TYPE NFLT IS NEW FLOAT; + SUBTYPE SNFLT IS NFLT RANGE -1.0 .. 1.0; + + FUNCTION IDENT (F : NFLT) RETURN NFLT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN F; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + BEGIN + IF SNFLT'(IDENT (2.0)) = 1.0 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SNFLT 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SNFLT 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SNFLT" ); + END; + + RESULT; +END C47005A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c47006a.ada b/gcc/testsuite/ada/acats/tests/c4/c47006a.ada new file mode 100644 index 000000000..c9587432a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47006a.ada @@ -0,0 +1,100 @@ +-- C47006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A FIXED POINT +-- TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE VALUE OF THE +-- OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK. + +-- RJW 7/23/86 + +WITH REPORT; USE REPORT; +PROCEDURE C47006A IS + + TYPE FIXED IS DELTA 0.5 RANGE -5.0 .. 5.0; + +BEGIN + + TEST( "C47006A", "WHEN THE TYPE MARK IN A QUALIFIED " & + "EXPRESSION DENOTES A FIXED POINT TYPE, " & + "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "WHEN THE VALUE OF THE OPERAND DOES NOT LIE " & + "WITHIN THE RANGE OF THE TYPE MARK" ); + + DECLARE + + SUBTYPE SFIXED IS FIXED RANGE -2.0 .. 2.0; + + FUNCTION IDENT (X : FIXED) RETURN FIXED IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + BEGIN + IF SFIXED'(IDENT (-5.0)) = -2.0 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SFIXED - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SFIXED - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SFIXED" ); + END; + + DECLARE + + TYPE NFIX IS NEW FIXED; + SUBTYPE SNFIX IS NFIX RANGE -2.0 .. 2.0; + + FUNCTION IDENT (X : NFIX) RETURN NFIX IS + BEGIN + RETURN NFIX (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + IF SNFIX'(IDENT (-5.0)) = -2.0 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SNFIX - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SNFIX - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SNFIX" ); + END; + + RESULT; +END C47006A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c47007a.ada b/gcc/testsuite/ada/acats/tests/c4/c47007a.ada new file mode 100644 index 000000000..bacc39f77 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47007a.ada @@ -0,0 +1,195 @@ +-- C47007A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A CONSTRAINED +-- ARRAY TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE BOUNDS +-- OF THE OPERAND ARE NOT THE SAME AS THE BOUNDS OF THE TYPE MARK. + +-- RJW 7/23/86 + +WITH REPORT; USE REPORT; +PROCEDURE C47007A IS + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + + TYPE TARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) + OF INTEGER; + + TYPE NARR IS NEW ARR; + + TYPE NTARR IS NEW TARR; + +BEGIN + + TEST( "C47007A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " & + "DENOTES A CONSTRAINED ARRAY TYPE, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED WHEN THE BOUNDS " & + "OF THE OPERAND ARE NOT THE SAME AS THE " & + "BOUNDS OF THE TYPE MARK" ); + + DECLARE + + SUBTYPE SARR IS ARR (IDENT_INT (1) .. IDENT_INT (1)); + A : ARR (IDENT_INT (2) .. IDENT_INT (2)); + BEGIN + A := SARR'(A'RANGE => 0); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE SARR" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE SARR" ); + END; + + DECLARE + + SUBTYPE NULLA IS ARR (IDENT_INT (1) .. IDENT_INT (0)); + A : ARR (IDENT_INT (2) .. IDENT_INT (1)); + + BEGIN + A := NULLA'(A'FIRST .. A'LAST => 0); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE NULLA" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE NULLA" ); + END; + + DECLARE + + SUBTYPE STARR IS TARR (IDENT_INT (1) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (5)); + A : TARR (IDENT_INT (2) .. IDENT_INT (6), + IDENT_INT (1) .. IDENT_INT (1)); + BEGIN + A := STARR'(A'RANGE => (A'RANGE (2) => 0)); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE STARR" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE STARR" ); + END; + + DECLARE + + SUBTYPE NULLT IS TARR (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (1) .. IDENT_INT (0)); + + A : TARR (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (2) .. IDENT_INT (1)); + BEGIN + A := NULLT'(A'FIRST .. A'LAST => + (A'FIRST (2) .. A'LAST (2) => 0)); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE NULLT" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE NULLT" ); + END; + + DECLARE + + SUBTYPE SNARR IS NARR (IDENT_INT (1) .. IDENT_INT (1)); + A : NARR (IDENT_INT (2) .. IDENT_INT (2)); + + BEGIN + A := SNARR'(A'RANGE => 0); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE SNARR" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE SNARR" ); + END; + + DECLARE + + SUBTYPE NULLNA IS NARR (IDENT_INT (1) .. IDENT_INT (0)); + A : NARR (IDENT_INT (2) .. IDENT_INT (1)); + + BEGIN + A := NULLNA'(A'RANGE => 0); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE NULLNA" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE NULLNA" ); + END; + + DECLARE + + SUBTYPE SNTARR IS NTARR (IDENT_INT (1) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (5)); + + A : NTARR (IDENT_INT (2) .. IDENT_INT (2), + IDENT_INT (1) .. IDENT_INT (5)); + BEGIN + A := SNTARR'(A'RANGE => (A'RANGE (2) => 0)); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE SNTARR" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE SNTARR" ); + END; + + DECLARE + + SUBTYPE NULLNT IS NTARR (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (1) .. IDENT_INT (0)); + + A : NTARR (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (1) .. IDENT_INT (1)); + BEGIN + A := NULLNT'(A'RANGE => (A'RANGE (2) => 0)); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE NULLNT" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE NULLNT" ); + END; + + RESULT; +END C47007A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c47008a.ada b/gcc/testsuite/ada/acats/tests/c4/c47008a.ada new file mode 100644 index 000000000..b2218297f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47008a.ada @@ -0,0 +1,299 @@ +-- C47008A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A +-- CONSTRAINED RECORD, PRIVATE, OR LIMITED PRIVATE TYPE, CHECK THAT +-- CONSTRAINT_ERROR IS RAISED WHEN THE DISCRIMINANTS OF THE OPERAND +-- DO NOT EQUAL THOSE OF THE TYPE MARK. + +-- HISTORY: +-- RJW 07/23/86 +-- DWC 07/24/87 CHANGED CODE TO TEST FOR FIRST DISCRIMINANT +-- AND LAST DISCRIMINANT MISMATCH. + +WITH REPORT; USE REPORT; +PROCEDURE C47008A IS + + TYPE GENDER IS (MALE, FEMALE, NEUTER); + + FUNCTION IDENT (G : GENDER) RETURN GENDER IS + BEGIN + RETURN GENDER'VAL (IDENT_INT (GENDER'POS (G))); + END IDENT; + +BEGIN + + TEST( "C47008A", "WHEN THE TYPE MARK IN A QUALIFIED " & + "EXPRESSION DENOTES A CONSTRAINED RECORD, " & + "PRIVATE, OR LIMITED PRIVATE TYPE, CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN THE " & + "DISCRIMANTS OF THE OPERAND DO NOT EQUAL " & + "THOSE OF THE TYPE MARK" ); + + DECLARE + + TYPE PERSON (SEX : GENDER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE WOMAN IS PERSON (IDENT (FEMALE)); + TOM : PERSON (MALE) := (SEX => IDENT (MALE)); + + BEGIN + IF WOMAN'(TOM) = PERSON'(SEX => MALE) THEN + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE WOMAN - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE WOMAN - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE WOMAN" ); + END; + + DECLARE + TYPE PAIR (SEX1, SEX2 : GENDER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE COUPLE IS PAIR (IDENT (FEMALE), IDENT (MALE)); + JONESES : PAIR (IDENT (MALE), IDENT (FEMALE)); + + BEGIN + IF COUPLE'(JONESES) = PAIR'(SEX1 => MALE, SEX2 => FEMALE) + THEN + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE COUPLE - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE COUPLE - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE COUPLE" ); + END; + + DECLARE + + PACKAGE PKG IS + TYPE PERSON (SEX : GENDER) IS PRIVATE; + SUBTYPE MAN IS PERSON (IDENT (MALE)); + + TESTWRITER : CONSTANT PERSON; + + PRIVATE + TYPE PERSON (SEX : GENDER) IS + RECORD + NULL; + END RECORD; + + TESTWRITER : CONSTANT PERSON := (SEX => FEMALE); + + END PKG; + + USE PKG; + + ROSA : PERSON (IDENT (FEMALE)); + + BEGIN + IF MAN'(ROSA) = TESTWRITER THEN + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE MAN - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE MAN - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE MAN" ); + END; + + DECLARE + PACKAGE PKG IS + TYPE PAIR (SEX1, SEX2 : GENDER) IS PRIVATE; + SUBTYPE FRIENDS IS PAIR (IDENT (FEMALE), IDENT (MALE)); + + ALICE_AND_JERRY : CONSTANT FRIENDS; + + PRIVATE + TYPE PAIR (SEX1, SEX2 : GENDER) IS + RECORD + NULL; + END RECORD; + + ALICE_AND_JERRY : CONSTANT FRIENDS := + (IDENT (FEMALE), IDENT (MALE)); + + END PKG; + + USE PKG; + + DICK_AND_JOE : PAIR (IDENT (MALE), IDENT (MALE)); + + BEGIN + IF FRIENDS'(DICK_AND_JOE) = ALICE_AND_JERRY THEN + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE FRIENDS - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE FRIENDS - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE FRIENDS" ); + END; + + DECLARE + + PACKAGE PKG1 IS + TYPE PERSON (SEX : GENDER) IS LIMITED PRIVATE; + SUBTYPE ANDROID IS PERSON (IDENT (NEUTER)); + + FUNCTION F RETURN PERSON; + FUNCTION "=" (A, B : PERSON) RETURN BOOLEAN; + PRIVATE + TYPE PERSON (SEX : GENDER) IS + RECORD + NULL; + END RECORD; + + END PKG1; + + PACKAGE BODY PKG1 IS + + FUNCTION F RETURN PERSON IS + BEGIN + RETURN PERSON'(SEX => (IDENT (MALE))); + END F; + + FUNCTION "=" (A, B : PERSON) RETURN BOOLEAN IS + BEGIN + RETURN A.SEX = B.SEX; + END; + + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + BEGIN + IF ANDROID'(F) = F THEN + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE " & + "ANDROID - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE " & + "ANDROID - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND " & + "WITH DISC NOT EQUAL TO THOSE OF " & + "SUBTYPE ANDROID" ); + END PKG2; + + BEGIN + NULL; + END; + + DECLARE + PACKAGE PKG1 IS + TYPE PAIR (SEX1, SEX2 : GENDER) IS LIMITED PRIVATE; + SUBTYPE LOVERS IS PAIR (IDENT (FEMALE), IDENT (MALE)); + + FUNCTION F RETURN PAIR; + FUNCTION "=" (A, B : PAIR) RETURN BOOLEAN; + PRIVATE + TYPE PAIR (SEX1, SEX2 : GENDER) IS + RECORD + NULL; + END RECORD; + END PKG1; + + PACKAGE BODY PKG1 IS + + FUNCTION F RETURN PAIR IS + BEGIN + RETURN PAIR'(SEX1 => (IDENT (FEMALE)), + SEX2 => (IDENT (FEMALE))); + END F; + + FUNCTION "=" (A, B : PAIR) RETURN BOOLEAN IS + BEGIN + RETURN A.SEX1 = B.SEX2; + END; + + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + BEGIN + IF LOVERS'(F) = F THEN + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE " & + "LOVERS - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE " & + "LOVERS - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND " & + "WITH DISC NOT EQUAL TO THOSE OF " & + "SUBTYPE LOVERS" ); + END PKG2; + + BEGIN + NULL; + END; + + RESULT; +END C47008A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c47009a.ada b/gcc/testsuite/ada/acats/tests/c4/c47009a.ada new file mode 100644 index 000000000..2fee5194e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47009a.ada @@ -0,0 +1,254 @@ +-- C47009A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A +-- CONSTRAINED ACCESS TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED +-- WHEN THE VALUE OF THE OPERAND IS NOT NULL AND THE DESIGNATED +-- OBJECT HAS INDEX BOUNDS OR DISCRIMINANT VALUES THAT DO NOT EQUAL +-- THOSE SPECIFIED IN THE ACCESS TYPE'S CONSTRAINT. + +-- HISTORY: +-- RJW 7/23/86 +-- DWC 07/24/87 REVISED TO MAKE THE ACCESS TYPE UNCONSTRAINED +-- AND TO PREVENT DEAD VARIABLE OPTIMIZATION. + +WITH REPORT; USE REPORT; +PROCEDURE C47009A IS + +BEGIN + + TEST( "C47009A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " & + "DENOTES A CONSTRAINED ACCESS TYPE, CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN THE " & + "VALUE OF THE OPERAND IS NOT NULL AND THE " & + "DESIGNATED OBJECT HAS INDEX BOUNDS OR " & + "DISCRIMINANT VALUES THAT DO NOT EQUAL THOSE " & + "SPECIFIED IN THE ACCESS TYPE'S CONSTRAINT" ); + + DECLARE + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + TYPE ACC1 IS ACCESS ARR; + SUBTYPE ACC1S IS ACC1 (IDENT_INT (1) .. IDENT_INT (5)); + A : ACC1; + B : ARR (IDENT_INT (2) .. IDENT_INT (6)); + + BEGIN + A := ACC1S'(NEW ARR'(B'FIRST .. B'LAST => 0)); + IF A'FIRST = 1 THEN + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC1 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC1 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC1" ); + END; + + DECLARE + + TYPE ARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) + OF INTEGER; + TYPE ACC2 IS ACCESS ARR; + SUBTYPE ACC2S IS ACC2 (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (1) .. IDENT_INT (1)); + A : ACC2; + B : ARR (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (2) .. IDENT_INT (2)); + + BEGIN + A := ACC2S'(NEW ARR'(B'RANGE => (B'RANGE (2) => 0))); + IF A'FIRST = 1 THEN + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC2 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC2 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC2" ); + END; + + DECLARE + + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACC3 IS ACCESS REC; + SUBTYPE ACC3S IS ACC3 (IDENT_INT (3)); + A : ACC3; + B : REC (IDENT_INT (5)) := (D => (IDENT_INT (5))); + + BEGIN + A := ACC3S'(NEW REC'(B)); + IF A = NULL THEN + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC3 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC3 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC3" ); + END; + + DECLARE + + TYPE REC (D1,D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACC4 IS ACCESS REC; + SUBTYPE ACC4S IS ACC4 (IDENT_INT (4), IDENT_INT (5)); + A : ACC4; + B : REC (IDENT_INT (5), IDENT_INT (4)) := + (D1 => (IDENT_INT (5)), D2 => (IDENT_INT (4))); + + BEGIN + A := ACC4S'(NEW REC'(B)); + IF A = NULL THEN + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC4 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC4 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR DISC VALUES " & + "DIFFERENT FROM THOSE OF TYPE ACC4" ); + END; + + DECLARE + + PACKAGE PKG IS + TYPE REC (D : INTEGER) IS PRIVATE; + + B : CONSTANT REC; + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + B : CONSTANT REC := (D => (IDENT_INT (4))); + END PKG; + + USE PKG; + + TYPE ACC5 IS ACCESS REC; + SUBTYPE ACC5S IS ACC5 (IDENT_INT (3)); + A : ACC5; + + BEGIN + A := ACC5S'(NEW REC'(B)); + IF A = NULL THEN + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC5 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC5 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR DISC VALUES " & + "DIFFERENT FROM THOSE OF TYPE ACC5" ); + END; + + DECLARE + + PACKAGE PKG1 IS + TYPE REC (D : INTEGER) IS LIMITED PRIVATE; + TYPE ACC6 IS ACCESS REC; + SUBTYPE ACC6S IS ACC6 (IDENT_INT (6)); + + FUNCTION F RETURN ACC6; + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG1; + + PACKAGE BODY PKG1 IS + + FUNCTION F RETURN ACC6 IS + BEGIN + RETURN NEW REC'(D => IDENT_INT (5)); + END F; + + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + A : ACC6; + + BEGIN + A := ACC6S'(F); + IF A = NULL THEN + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC6 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC6 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR DISC " & + "VALUES DIFFERENT FROM THOSE OF TYPE " & + "ACC6" ); + END PKG2; + + BEGIN + NULL; + END; + + RESULT; +END C47009A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c47009b.ada b/gcc/testsuite/ada/acats/tests/c4/c47009b.ada new file mode 100644 index 000000000..accd787d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47009b.ada @@ -0,0 +1,282 @@ +-- C47009B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES AN ACCESS +-- TYPE, CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN THE VALUE +-- OF THE OPERAND IS NULL. + +-- HISTORY: +-- RJW 07/23/86 CREATED ORIGINAL TEST. +-- BCB 08/18/87 CHANGED HEADER TO STANDARD HEADER FORMAT. CHANGED +-- CONSTRAINTS OF B SUBTYPES TO VALUES WHICH ARE +-- CLOSER TO THE VALUES OF THE A SUBTYPES. INDENTED +-- THE EXCEPTION STATEMENTS IN SUBTEST 11. + +WITH REPORT; USE REPORT; +PROCEDURE C47009B IS + +BEGIN + + TEST( "C47009B", "WHEN THE TYPE MARK IN A QUALIFIED " & + "EXPRESSION DENOTES AN ACCESS TYPE, " & + "CHECK THAT CONSTRAINT_ERROR IS NOT " & + "RAISED WHEN THE VALUE OF THE OPERAND IS NULL" ); + + DECLARE + + TYPE ACC1 IS ACCESS BOOLEAN; + A : ACC1; + + BEGIN + A := ACC1'(NULL); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC1" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC1" ); + END; + + DECLARE + + TYPE ACC2 IS ACCESS INTEGER; + A : ACC2; + + BEGIN + A := ACC2'(NULL); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC2" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC2" ); + END; + + DECLARE + + TYPE CHAR IS ('A', 'B'); + TYPE ACC3 IS ACCESS CHAR; + A : ACC3; + + BEGIN + A := ACC3'(NULL); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC3" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC3" ); + END; + + DECLARE + + TYPE FLOAT1 IS DIGITS 5 RANGE -1.0 .. 1.0; + TYPE ACC4 IS ACCESS FLOAT1; + A : ACC4; + + BEGIN + A := ACC4'(NULL); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC4" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC4" ); + END; + + DECLARE + + TYPE FIXED IS DELTA 0.5 RANGE -1.0 .. 1.0; + TYPE ACC5 IS ACCESS FIXED; + A : ACC5; + + BEGIN + A := ACC5'(NULL); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC5" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC5" ); + END; + + DECLARE + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + TYPE ACC6 IS ACCESS ARR; + SUBTYPE ACC6A IS ACC6 (IDENT_INT (1) .. IDENT_INT (5)); + SUBTYPE ACC6B IS ACC6 (IDENT_INT (2) .. IDENT_INT (10)); + A : ACC6A; + B : ACC6B; + + BEGIN + A := ACC6A'(B); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " & + "TYPE ACC6" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " & + "TYPE ACC6" ); + END; + + DECLARE + + TYPE ARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) + OF INTEGER; + TYPE ACC7 IS ACCESS ARR; + SUBTYPE ACC7A IS ACC7 (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (1) .. IDENT_INT (1)); + SUBTYPE ACC7B IS ACC7 (IDENT_INT (1) .. IDENT_INT (15), + IDENT_INT (1) .. IDENT_INT (10)); + A : ACC7A; + B : ACC7B; + + BEGIN + A := ACC7A'(B); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " & + "TYPE ACC7" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " & + "TYPE ACC7" ); + END; + + DECLARE + + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACC8 IS ACCESS REC; + SUBTYPE ACC8A IS ACC8 (IDENT_INT (5)); + SUBTYPE ACC8B IS ACC8 (IDENT_INT (6)); + A : ACC8A; + B : ACC8B; + + BEGIN + A := ACC8A'(B); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " & + "TYPE ACC8" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " & + "TYPE ACC8" ); + END; + + DECLARE + + TYPE REC (D1,D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACC9 IS ACCESS REC; + SUBTYPE ACC9A IS ACC9 (IDENT_INT (4), IDENT_INT (5)); + SUBTYPE ACC9B IS ACC9 (IDENT_INT (5), IDENT_INT (4)); + A : ACC9A; + B : ACC9B; + + BEGIN + A := ACC9A'(B); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " & + "TYPE ACC9" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " & + "TYPE ACC9" ); + END; + + DECLARE + + PACKAGE PKG IS + TYPE REC (D : INTEGER) IS PRIVATE; + + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + END PKG; + + USE PKG; + + TYPE ACC10 IS ACCESS REC; + SUBTYPE ACC10A IS ACC10 (IDENT_INT (10)); + SUBTYPE ACC10B IS ACC10 (IDENT_INT (9)); + A : ACC10A; + B : ACC10B; + + BEGIN + A := ACC10A'(B); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " & + "TYPE ACC10" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " & + "TYPE ACC10" ); + END; + + DECLARE + + PACKAGE PKG1 IS + TYPE REC (D : INTEGER) IS LIMITED PRIVATE; + + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + TYPE ACC11 IS ACCESS REC; + SUBTYPE ACC11A IS ACC11 (IDENT_INT (11)); + SUBTYPE ACC11B IS ACC11 (IDENT_INT (12)); + A : ACC11A; + B : ACC11B; + + BEGIN + A := ACC11A'(B); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF" & + " TYPE ACC11" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " & + "TYPE ACC11" ); + END PKG2; + + BEGIN + NULL; + END; + + RESULT; +END C47009B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48004a.ada b/gcc/testsuite/ada/acats/tests/c4/c48004a.ada new file mode 100644 index 000000000..5dd315a17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48004a.ada @@ -0,0 +1,60 @@ +-- C48004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE FORM "NEW T" IS PERMITTED IF T IS A SCALAR SUBTYPE. + +-- RM 01/12/80 +-- JBG 03/03/83 +-- EG 07/05/84 + +WITH REPORT; + +PROCEDURE C48004A IS + + USE REPORT; + +BEGIN + + TEST("C48004A","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF " & + "T IS A SCALAR SUBTYPE"); + + DECLARE + + SUBTYPE TA IS INTEGER RANGE 1 .. 7; + TYPE ATA IS ACCESS TA; + VA : ATA; + + BEGIN + + VA := NEW TA; + VA.ALL := IDENT_INT(6); + IF VA.ALL /= 6 THEN + FAILED ("INCORRECT VALUE"); + END IF; + + END; + + RESULT; + +END C48004A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48004b.ada b/gcc/testsuite/ada/acats/tests/c4/c48004b.ada new file mode 100644 index 000000000..0ba6c07b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48004b.ada @@ -0,0 +1,140 @@ +-- C48004B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE FORM "NEW T" IS PERMITTED IF T IS A CONSTRAINED +-- RECORD, PRIVATE, OR LIMITED PRIVATE TYPE. + +-- RM 01/12/80 +-- JBG 03/03/83 +-- EG 07/05/84 + +WITH REPORT; + +PROCEDURE C48004B IS + + USE REPORT; + +BEGIN + + TEST("C48004B","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF " & + "T IS A CONSTRAINED RECORD, PRIVATE, OR " & + "LIMITED PRIVATE TYPE"); + + DECLARE + + TYPE TB0(A , B : INTEGER ) IS + RECORD + C : INTEGER := 7; + END RECORD; + SUBTYPE TB IS TB0( 2 , 3 ); + TYPE ATB IS ACCESS TB0; + VB : ATB; + + TYPE TBB0( A , B : INTEGER := 5 ) IS + RECORD + C : INTEGER := 6; + END RECORD; + SUBTYPE TBB IS TBB0( 4 , 5 ); + TYPE ATBB IS ACCESS TBB0; + VBB : ATBB; + + PACKAGE P IS + TYPE PRIV0( A , B : INTEGER ) IS PRIVATE; + TYPE LPRIV0( A , B : INTEGER := 1 ) IS LIMITED PRIVATE; + FUNCTION FUN(LP : LPRIV0) RETURN INTEGER; + PRIVATE + TYPE PRIV0( A , B : INTEGER ) IS + RECORD + Q : INTEGER; + END RECORD; + TYPE LPRIV0( A , B : INTEGER := 1 ) IS + RECORD + Q : INTEGER := 7; + END RECORD; + END P; + + USE P; + + SUBTYPE PRIV IS P.PRIV0( 12 , 13 ); + TYPE A_PRIV IS ACCESS P.PRIV0; + VP : A_PRIV; + + TYPE A_LPRIV IS ACCESS LPRIV0; + VLP : A_LPRIV; + + TYPE LCR(A, B : INTEGER := 4) IS + RECORD + C : P.LPRIV0; + END RECORD; + SUBTYPE SLCR IS LCR(1, 2); + TYPE A_SLCR IS ACCESS SLCR; + VSLCR : A_SLCR; + + PACKAGE BODY P IS + FUNCTION FUN(LP : LPRIV0) RETURN INTEGER IS + BEGIN + RETURN LP.Q; + END FUN; + END P; + + BEGIN + + VB := NEW TB; + IF ( VB.A /= IDENT_INT(2) OR + VB.B /= 3 OR + VB.C /= 7 ) THEN FAILED( "WRONG VALUES - B1" ); + END IF; + + VBB := NEW TBB0; + IF ( VBB.A /= IDENT_INT(5) OR + VBB.B /= 5 OR + VBB.C /= 6 ) THEN + FAILED( "WRONG VALUES - B2" ); + END IF; + + VP := NEW PRIV; + IF ( VP.A /= IDENT_INT(12) OR + VP.B /= 13 ) THEN + FAILED( "WRONG VALUES - B3" ); + END IF; + + VLP := NEW LPRIV0; + IF ( VLP.A /= IDENT_INT(1) OR + VLP.B /= 1 OR + P.FUN(VLP.ALL) /= IDENT_INT(7) ) THEN + FAILED( "WRONG VALUES - B4" ); + END IF; + + VSLCR := NEW SLCR; + IF ( VSLCR.A /= IDENT_INT(1) OR + VSLCR.B /= IDENT_INT(2) OR + P.FUN(VSLCR.C) /= IDENT_INT(7) ) THEN + FAILED ("WRONG VALUES - B5"); + END IF; + + END; + + RESULT; + +END C48004B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48004c.ada b/gcc/testsuite/ada/acats/tests/c4/c48004c.ada new file mode 100644 index 000000000..2b867a070 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48004c.ada @@ -0,0 +1,101 @@ +-- C48004C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE FORM "NEW T" IS PERMITTED IF T IS AN UNCONSTRAINED +-- RECORD, PRIVATE, OR LIMITED TYPE WHOSE DISCRIMINANTS HAVE DEFAULT +-- VALUES. + +-- EG 08/03/84 + +WITH REPORT; + +PROCEDURE C48004C IS + + USE REPORT; + +BEGIN + + TEST("C48004C","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF " & + "T IS AN UNCONSTRAINED RECORD, PRIVATE, OR " & + "LIMITED TYPE WHOSE DISCRIMINANTS HAVE DEFAULT " & + "VALUES"); + + DECLARE + + TYPE UR(A : INTEGER := 1; B : INTEGER := 2) IS + RECORD + C : INTEGER := 7; + END RECORD; + + PACKAGE P IS + + TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS PRIVATE; + TYPE UL(A, B : INTEGER := 1) IS LIMITED PRIVATE; + + PRIVATE + + TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS + RECORD + Q : INTEGER; + END RECORD; + TYPE UL(A, B : INTEGER := 1) IS + RECORD + Q : INTEGER; + END RECORD; + + END P; + + USE P; + + TYPE A_UR IS ACCESS UR; + TYPE A_UP IS ACCESS UP; + TYPE A_UL IS ACCESS UL; + + V_UR : A_UR; + V_UP : A_UP; + V_UL : A_UL; + + BEGIN + + V_UR := NEW UR; + IF ( V_UR.A /= IDENT_INT(1) OR V_UR.B /= 2 OR + V_UR.C /= 7 ) THEN + FAILED("WRONG VALUES - UR"); + END IF; + + V_UP := NEW UP; + IF ( V_UP.A /= IDENT_INT(12) OR V_UP.B /= 13 ) THEN + FAILED("WRONG VALUES - UP"); + END IF; + + V_UL := NEW UL; + IF ( V_UL.A /= IDENT_INT(1) OR V_UL.B /= 1 ) THEN + FAILED("WRONG VALUES - UL"); + END IF; + + END; + + RESULT; + +END C48004C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48004d.ada b/gcc/testsuite/ada/acats/tests/c4/c48004d.ada new file mode 100644 index 000000000..9454327dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48004d.ada @@ -0,0 +1,124 @@ +-- C48004D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE FORM "NEW T" IS PERMITTED IF T IS A RECORD, PRIVATE, +-- OR LIMITED TYPE WITHOUT DISCRIMINANTS. + +-- RM 01/12/80 +-- JBG 03/03/83 +-- EG 07/05/84 + +WITH REPORT; + +PROCEDURE C48004D IS + + USE REPORT; + +BEGIN + + TEST("C48004D","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF T " & + "IS A RECORD, PRIVATE, OR LIMITED TYPE WITHOUT " & + "DISCRIMINANTS"); + + DECLARE + + TYPE TC IS + RECORD + C : INTEGER := 18; + END RECORD; + TYPE ATC IS ACCESS TC; + VC : ATC; + + PACKAGE P IS + TYPE PRIV IS PRIVATE; + TYPE LPRIV IS LIMITED PRIVATE; + TYPE A_PRIV IS ACCESS PRIV; + TYPE A_LPRIV IS ACCESS LPRIV; + PROCEDURE CHECK( X: A_PRIV ); + PROCEDURE LCHECK( X: A_LPRIV ); + PROCEDURE LRCHECK( X: LPRIV ); + PRIVATE + TYPE PRIV IS + RECORD + Q : INTEGER := 19; + END RECORD; + TYPE LPRIV IS + RECORD + Q : INTEGER := 20; + END RECORD; + END P; + + + VP : P.A_PRIV; + VLP : P.A_LPRIV; + + TYPE LCR IS + RECORD + C : P.LPRIV; + END RECORD; + TYPE A_LCR IS ACCESS LCR; + VLCR : A_LCR; + + PACKAGE BODY P IS + + PROCEDURE CHECK( X: A_PRIV ) IS + BEGIN + IF X.Q /= 19 THEN FAILED( "WRONG VALUES - C2" ); + END IF; + END CHECK; + + PROCEDURE LCHECK( X: A_LPRIV ) IS + BEGIN + IF X.Q /= 20 THEN FAILED( "WRONG VALUES - C3" ); + END IF; + END LCHECK; + + PROCEDURE LRCHECK (X : LPRIV) IS + BEGIN + IF X.Q /= 20 THEN + FAILED ("WRONG VALUES - C4"); + END IF; + END LRCHECK; + + END P; + + BEGIN + + VC := NEW TC; + IF VC.C /= 18 THEN FAILED( "WRONG VALUES - C1" ); + END IF; + + VP := NEW P.PRIV; + P.CHECK( VP ); + VLP := NEW P.LPRIV; + P.LCHECK( VLP ); + + VLCR := NEW LCR; + P.LRCHECK( VLCR.ALL.C ); + + END; + + RESULT; + +END C48004D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48004e.ada b/gcc/testsuite/ada/acats/tests/c4/c48004e.ada new file mode 100644 index 000000000..22e62ba84 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48004e.ada @@ -0,0 +1,89 @@ +-- C48004E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE FORM "NEW T" IS PERMITTED IF T IS A CONSTRAINED ARRAY +-- TYPE. + +-- RM 01/12/80 +-- JBG 03/03/83 +-- EG 07/05/84 + +WITH REPORT; + +PROCEDURE C48004E IS + + USE REPORT; + +BEGIN + + TEST("C48004E","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF T " & + "IS A CONSTRAINED ARRAY TYPE"); + + DECLARE + + TYPE ARR0 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN; + SUBTYPE ARR IS ARR0(1 .. 10); + TYPE A_ARR IS ACCESS ARR; + VARR : A_ARR; + + PACKAGE P IS + TYPE LPRIV IS LIMITED PRIVATE; + FUNCTION CHECK (X : LPRIV) RETURN INTEGER; + PRIVATE + TYPE LPRIV IS + RECORD + Q : INTEGER := 20; + END RECORD; + END P; + + TYPE LPARR IS ARRAY(1 .. 2) OF P.LPRIV; + TYPE A_LPARR IS ACCESS LPARR; + + V_A_LPARR : A_LPARR; + + PACKAGE BODY P IS + FUNCTION CHECK (X : LPRIV) RETURN INTEGER IS + BEGIN + RETURN X.Q; + END CHECK; + END P; + + BEGIN + + VARR := NEW ARR; + IF ( VARR'FIRST /= IDENT_INT(1) OR + VARR'LAST /= 10 ) THEN FAILED("WRONG BOUNDS - CASE 1"); + END IF; + + V_A_LPARR := NEW LPARR; + IF ( P.CHECK(V_A_LPARR.ALL(1)) /= IDENT_INT(20) OR + P.CHECK(V_A_LPARR.ALL(2)) /= IDENT_INT(20) ) THEN + FAILED ("WRONG VALUES - CASE 2"); + END IF; + + END; + + RESULT; + +END C48004E; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48004f.ada b/gcc/testsuite/ada/acats/tests/c4/c48004f.ada new file mode 100644 index 000000000..50ab9e71e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48004f.ada @@ -0,0 +1,99 @@ +-- C48004F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE FORM "NEW T" IS PERMITTED IF T IS AN ACCESS TYPE. + +-- RM 01/12/80 +-- JBG 03/03/83 +-- EG 07/05/84 + +WITH REPORT; + +PROCEDURE C48004F IS + + USE REPORT; + +BEGIN + + TEST("C48004F","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF T " & + "IS AN ACCESS TYPE"); + + DECLARE + + TYPE AINT IS ACCESS INTEGER; + TYPE A_AINT IS ACCESS AINT; + VA_AINT : A_AINT; + + TYPE AST IS ACCESS STRING; + SUBTYPE CAST_4 IS AST(1 .. 4); + TYPE A_AST IS ACCESS AST; + TYPE ACAST_3 IS ACCESS AST(1 .. 3); + V_AAST : A_AST; + V_ACAST_3 : ACAST_3; + + TYPE UR(A, B : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + SUBTYPE CR IS UR(1, 2); + TYPE A_CR IS ACCESS CR; + TYPE AA_CR IS ACCESS A_CR; + V_AA_CR : AA_CR; + + BEGIN + + VA_AINT := NEW AINT; + IF VA_AINT.ALL /= NULL THEN + FAILED ("VARIABLE IS NOT NULL - CASE 1"); + END IF; + + BEGIN + + V_ACAST_3 := NEW CAST_4; + IF V_ACAST_3.ALL /= NULL THEN + FAILED ("VARIABLE IS NOT NULL - CASE 2"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - CASE 2"); + + END; + + V_AAST := NEW AST; + IF V_AAST.ALL /= NULL THEN + FAILED ("VARIABLE IS NOT NULL - CASE 3"); + END IF; + + V_AA_CR := NEW A_CR; + IF V_AA_CR.ALL /= NULL THEN + FAILED ("VARIABLE IS NOT NULL - CASE 4"); + END IF; + + END; + + RESULT; + +END C48004F; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48005a.ada b/gcc/testsuite/ada/acats/tests/c4/c48005a.ada new file mode 100644 index 000000000..13bea3af1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48005a.ada @@ -0,0 +1,121 @@ +-- C48005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT AN ALLOCATOR OF THE FORM "NEW T X" ALLOCATES A NEW OBJECT +-- EACH TIME IT IS EXECUTED AND THAT IF T IS AN UNCONSTRAINED RECORD, +-- PRIVATE, OR LIMITED TYPE, THE ALLOCATED OBJECT HAS THE DISCRIMINANT +-- VALUES SPECIFIED BY X. + +-- EG 08/08/84 + +WITH REPORT; + +PROCEDURE C48005A IS + + USE REPORT; + +BEGIN + + TEST("C48005A","CHECK THAT THE FORM 'NEW T X' ALLOCATES A " & + "NEW OBJECT AND THAT IF T IS AN UNCONSTRAINED " & + "RECORD, PRIVATE, OR LIMITED TYPE, THE " & + "ALLOCATED OBJECT HAS THE DISCRIMINANT " & + "VALUES SPECIFIED BY X"); + + DECLARE + + TYPE UR1(A : INTEGER) IS + RECORD + B : INTEGER := 7; + C : INTEGER := 4; + END RECORD; + TYPE UR2(A : INTEGER) IS + RECORD + CASE A IS + WHEN 1 => + A1 : INTEGER := 4; + WHEN 2 => + A2 : INTEGER := 5; + WHEN OTHERS => + NULL; + END CASE; + END RECORD; + + TYPE A_UR1 IS ACCESS UR1; + TYPE A_UR2 IS ACCESS UR2; + + V1AUR1 : A_UR1; + V1AUR2, V2AUR2 : A_UR2; + + TYPE REC (A : INTEGER) IS + RECORD + B : INTEGER; + END RECORD; + + TYPE A_REC IS ACCESS REC; + + V_A_REC : A_REC; + + TYPE ARR IS ARRAY(1 .. 1) OF INTEGER; + + TYPE RECVAL IS + RECORD + A : INTEGER; + B : ARR; + END RECORD; + + FUNCTION FUN (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(A); + END FUN; + FUNCTION FUN (A : INTEGER) RETURN RECVAL IS + BEGIN + FAILED ("WRONG OVERLOADED FUNCTION CALLED"); + RETURN (1, (1 => 2)); + END FUN; + + BEGIN + + V1AUR1 := NEW UR1(3); + IF ( V1AUR1.A /= 3 OR V1AUR1.B /= 7 OR + V1AUR1.C /= IDENT_INT(4) ) THEN + FAILED("WRONG VALUES - V1UAR1"); + END IF; + + V1AUR2 := NEW UR2(IDENT_INT(2)); + IF ( V1AUR2.A /= 2 OR V1AUR2.A2 /= IDENT_INT(5) ) THEN + FAILED("WRONG VALUES - V1AUR2"); + END IF; + + V2AUR2 := NEW UR2(IDENT_INT(3)); + IF ( V2AUR2.A /= IDENT_INT(3) ) THEN + FAILED("WRONG VALUES - V2AUR2"); + END IF; + + V_A_REC := NEW REC(FUN(2)); + END; + + RESULT; + +END C48005A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48005b.ada b/gcc/testsuite/ada/acats/tests/c4/c48005b.ada new file mode 100644 index 000000000..c03bde6e0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48005b.ada @@ -0,0 +1,78 @@ +-- C48005B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT AN ALLOCATOR OF THE FORM "NEW T X" ALLOCATES A NEW OBJECT +-- EACH TIME IT IS EXECUTED AND THAT IF X IS AN INDEX CONSTRAINT AND T +-- AN UNCONSTRAINED ARRAY TYPE, THE ALLOCATED OBJECT HAS THE INDEX +-- BOUNDS SPECIFIED BY X. + +-- EG 08/10/84 + +WITH REPORT; + +PROCEDURE C48005B IS + + USE REPORT; + +BEGIN + + TEST("C48005B","CHECK THAT THE FORM 'NEW T X' ALLOCATES A " & + "NEW OBJECT AND THAT IF X IS AN INDEX " & + "CONSTRAINT AND T AN UNCONSTRAINED ARRAY " & + "TYPE, THE ALLOCATED OBJECT HAS THE INDEX " & + "BOUND SPECIFIED BY X"); + + DECLARE + + TYPE UA1 IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE UA2 IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) + OF INTEGER; + + TYPE A_UA1 IS ACCESS UA1; + TYPE A_UA2 IS ACCESS UA2; + + V_A_UA1 : A_UA1; + V_A_UA2 : A_UA2; + + BEGIN + + V_A_UA1 := NEW UA1(4 .. 7); + IF ( V_A_UA1'FIRST /= IDENT_INT(4) OR + V_A_UA1'LAST /= IDENT_INT(7) ) THEN + FAILED("WRONG ARRAY BOUNDS - V_A_UA1"); + END IF; + + V_A_UA2 := NEW UA2(2 .. 3, 4 .. 6); + IF ( V_A_UA2'FIRST(1) /= IDENT_INT(2) OR + V_A_UA2'LAST(1) /= IDENT_INT(3) OR + V_A_UA2'FIRST(2) /= IDENT_INT(4) OR + V_A_UA2'LAST(2) /= IDENT_INT(6) ) THEN + FAILED("WRONG ARRAY BOUNDS - V_A_UA2"); + END IF; + + END; + + RESULT; + +END C48005B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48006a.ada b/gcc/testsuite/ada/acats/tests/c4/c48006a.ada new file mode 100644 index 000000000..22c0582ac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48006a.ada @@ -0,0 +1,96 @@ +-- C48006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT AN ALLOCATOR OF THE FORM "NEW T'(X)" ALLOCATES A NEW +-- OBJECT EACH TIME IT IS EXECUTED AND THAT IF T IS A SCALAR OR ACCESS +-- TYPE, THE ALLOCATED OBJECT HAS THE VALUE OF X. + +-- RM 01/14/80 +-- RM 01/O1/82 +-- SPS 10/27/82 +-- EG 07/05/84 + +WITH REPORT; + +PROCEDURE C48006A IS + + USE REPORT; + +BEGIN + + TEST("C48006A","CHECK THAT THE FORM 'NEW T'(X)' " & + "ALLOCATES A NEW OBJECT " & + "AND THAT IF T IS A SCALAR OR ACCESS TYPE, THE " & + "ALLOCATED OBJECT HAS THE VALUE OF X"); + + DECLARE + + TYPE ATA IS ACCESS INTEGER; + TYPE AATA IS ACCESS ATA; + VA1, VA2, VA3 : ATA; + VAA1, VAA2, VAA3 : AATA; + + BEGIN + + VA1 := NEW INTEGER'(5 + 7); + IF VA1.ALL /= IDENT_INT(12) THEN + FAILED("WRONG VALUES - VA1"); + END IF; + + VA2 := NEW INTEGER'(1 + 2); + IF (VA1.ALL /= IDENT_INT(12) OR + VA2.ALL /= IDENT_INT( 3)) THEN + FAILED("WRONG VALUES - VA2"); + END IF; + + VA3 := NEW INTEGER'(IDENT_INT(3) + IDENT_INT(4)); + IF (VA1.ALL /= IDENT_INT(12) OR + VA2.ALL /= IDENT_INT( 3) OR + VA3.ALL /= IDENT_INT( 7)) THEN + FAILED("WRONG VALUES - VA3"); + END IF; + + VAA1 := NEW ATA'(NEW INTEGER'(3)); + IF VAA1.ALL.ALL /= IDENT_INT(3) THEN + FAILED ("WRONG VALUES - VAA1"); + END IF; + + VAA2 := NEW ATA'(NEW INTEGER'(IDENT_INT(5))); + IF (VAA1.ALL.ALL /= 3 OR + VAA2.ALL.ALL /= 5 ) THEN + FAILED ("WRONG VALUES - VAA2"); + END IF; + + VAA3 := NEW ATA'(NEW INTEGER'(IDENT_INT(6))); + IF (VAA1.ALL.ALL /= 3 OR + VAA2.ALL.ALL /= 5 OR + VAA3.ALL.ALL /= 6 ) THEN + FAILED ("WRONG VALUES - VAA3"); + END IF; + + END; + + RESULT; + +END C48006A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48006b.ada b/gcc/testsuite/ada/acats/tests/c4/c48006b.ada new file mode 100644 index 000000000..001b8897c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48006b.ada @@ -0,0 +1,236 @@ +-- C48006B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT AN ALLOCATOR OF THE FORM "NEW T'(X)" ALLOCATES A NEW +-- OBJECT EACH TIME IT IS EXECUTED AND THAT IF T IS A RECORD, ARRAY, OR +-- PRIVATE TYPE (CONSTRAINED OR UNCONSTRAINED), THE ALLOCATED OBJECT HAS +-- THE VALUE OF (X). + +-- RM 01/14/80 +-- RM 01/O1/82 +-- SPS 10/27/82 +-- EG 07/05/84 +-- JBG 11/08/85 AVOID CONFLICT WITH AI-7 OR AI-275 + +WITH REPORT; + +PROCEDURE C48006B IS + + USE REPORT ; + +BEGIN + + TEST("C48006B","CHECK THAT THE FORM 'NEW T'(X)' " & + "ALLOCATES A NEW OBJECT " & + "AND THAT IF T IS A RECORD, ARRAY, OR PRIVATE " & + "TYPE, THE ALLOCATED OBJECT HAS THE VALUE (X)"); + + -- RECORD OR ARRAY TYPE (CONSTRAINED OR UNCONSTRAINED) + + DECLARE + + TYPE TB0( A , B : INTEGER ) IS + RECORD + C : INTEGER := 7 ; + END RECORD; + SUBTYPE TB IS TB0( 2 , 3 ); + TYPE ATB IS ACCESS TB ; + TYPE ATB0 IS ACCESS TB0 ; + VB1 , VB2 : ATB ; + VB01 , VB02 : ATB0 ; + + TYPE ARR0 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + SUBTYPE ARR IS ARR0( 1..4 ); + TYPE A_ARR IS ACCESS ARR ; + TYPE A_ARR0 IS ACCESS ARR0 ; + VARR1 , VARR2 : A_ARR ; + VARR01 , VARR02 : A_ARR0 ; + + BEGIN + + VB1 := NEW TB'( 2 , 3 , 5 ); + IF ( VB1.A /=IDENT_INT( 2) OR + VB1.B /=IDENT_INT( 3) OR + VB1.C /=IDENT_INT( 5) ) + THEN FAILED( "WRONG VALUES - B1 1" ); + END IF; + + VB2 := NEW TB'( IDENT_INT(2), IDENT_INT(3), IDENT_INT(6)); + IF ( VB2.A /= 2 OR + VB2.B /= 3 OR + VB2.C /= 6 OR + VB1.A /= 2 OR + VB1.B /= 3 OR + VB1.C /= 5 ) + THEN FAILED( "WRONG VALUES - B1 2" ); + END IF; + + VB01 := NEW TB0'( 1 , 2 , 3 ); + IF ( VB01.A /=IDENT_INT( 1) OR + VB01.B /=IDENT_INT( 2) OR + VB01.C /=IDENT_INT( 3) ) + THEN FAILED( "WRONG VALUES - B2 1" ); + END IF; + + VB02 := NEW TB0'( IDENT_INT(4) , IDENT_INT(5) , + IDENT_INT(6) ); + IF ( VB02.A /=IDENT_INT( 4) OR + VB02.B /=IDENT_INT( 5) OR + VB02.C /=IDENT_INT( 6) OR + VB01.A /=IDENT_INT( 1) OR + VB01.B /=IDENT_INT( 2) OR + VB01.C /=IDENT_INT( 3) ) + THEN FAILED( "WRONG VALUES - B2 2" ); + END IF; + + VARR1 := NEW ARR'( 5 , 6 , 7 , 8 ); + IF ( VARR1(1) /=IDENT_INT( 5) OR + VARR1(2) /=IDENT_INT( 6) OR + VARR1(3) /=IDENT_INT( 7) OR + VARR1(4) /=IDENT_INT( 8) ) + THEN FAILED( "WRONG VALUES - B3 1" ); + END IF ; + + VARR2 := NEW ARR'( IDENT_INT(1) , IDENT_INT(2) , IDENT_INT(3), + IDENT_INT(4) ); + IF ( VARR2(1) /= 1 OR + VARR2(2) /= 2 OR + VARR2(3) /= 3 OR + VARR2(4) /= 4 OR + VARR1(1) /= 5 OR + VARR1(2) /= 6 OR + VARR1(3) /= 7 OR + VARR1(4) /= 8 ) + THEN FAILED( "WRONG VALUES - B3 2" ); + END IF ; + + VARR01 := NEW ARR0'( 11 , 12 , 13 ); + IF ( VARR01(INTEGER'FIRST) /= IDENT_INT(11) OR + VARR01(INTEGER'FIRST + 1) /= IDENT_INT(12) OR + VARR01(INTEGER'FIRST + 2) /= IDENT_INT(13) ) + THEN FAILED( "WRONG VALUES - B4 1" ); + END IF ; + IF ( VARR01.ALL'FIRST /= IDENT_INT( INTEGER'FIRST ) OR + VARR01.ALL'LAST /= IDENT_INT( INTEGER'FIRST + 2 ) ) + THEN FAILED( "WRONG VALUES - B4 2" ); + END IF ; + + VARR02 := NEW ARR0'( 1 => IDENT_INT(14) , 2 => IDENT_INT(15)); + IF ( VARR02(1) /= 14 OR + VARR02(2) /= 15 OR + VARR01(INTEGER'FIRST) /= 11 OR + VARR01(INTEGER'FIRST + 1) /= 12 OR + VARR01(INTEGER'FIRST + 2) /= 13 ) + THEN FAILED( "WRONG VALUES - B4 3" ); + END IF ; + + END ; + + -- PRIVATE TYPE (CONSTRAINED OR UNCONSTRAINED) + + DECLARE + + PACKAGE P IS + TYPE UP(A, B : INTEGER) IS PRIVATE; +-- SUBTYPE CP IS UP(1, 2); +-- TYPE A_CP IS ACCESS CP; + TYPE A_UP IS ACCESS UP; + CONS1_UP : CONSTANT UP; + CONS2_UP : CONSTANT UP; + CONS3_UP : CONSTANT UP; + CONS4_UP : CONSTANT UP; +-- PROCEDURE CHECK1 (X : A_CP); +-- PROCEDURE CHECK2 (X, Y : A_CP); + PROCEDURE CHECK3 (X : A_UP); + PROCEDURE CHECK4 (X, Y : A_UP); + PRIVATE + TYPE UP(A, B : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + CONS1_UP : CONSTANT UP := (1, 2, 3); + CONS2_UP : CONSTANT UP := (IDENT_INT(1), IDENT_INT(2), + IDENT_INT(4)); + CONS3_UP : CONSTANT UP := (7, 8, 9); + CONS4_UP : CONSTANT UP := (IDENT_INT(10), IDENT_INT(11), + IDENT_INT(12)); + END P; + + USE P; + +-- V_A_CP1, V_A_CP2 : A_CP; + V_A_UP1, V_A_UP2 : A_UP; + + PACKAGE BODY P IS +-- PROCEDURE CHECK1 (X : A_CP) IS +-- BEGIN +-- IF (X.A /= IDENT_INT(1) OR +-- X.B /= IDENT_INT(2) OR +-- X.C /= IDENT_INT(3)) THEN +-- FAILED ("WRONG VALUES - CP1"); +-- END IF; +-- END CHECK1; +-- PROCEDURE CHECK2 (X, Y : A_CP) IS +-- BEGIN +-- IF (X.A /= 1 OR X.B /= 2 OR X.C /= 3 OR +-- Y.A /= 1 OR Y.B /= 2 OR Y.C /= 4) THEN +-- FAILED ("WRONG VALUES - CP2"); +-- END IF; +-- END CHECK2; + PROCEDURE CHECK3 (X : A_UP) IS + BEGIN + IF (X.A /= IDENT_INT(7) OR + X.B /= IDENT_INT(8) OR + X.C /= IDENT_INT(9)) THEN + FAILED ("WRONG VALUES - UP1"); + END IF; + END CHECK3; + PROCEDURE CHECK4 (X, Y : A_UP) IS + BEGIN + IF (X.A /= 7 OR X.B /= 8 OR X.C /= 9 OR + Y.A /= 10 OR Y.B /= 11 OR Y.C /= 12) THEN + FAILED ("WRONG VALUES - UP2"); + END IF; + END CHECK4; + END P; + + BEGIN + +-- V_A_CP1 := NEW CP'(CONS1_UP); +-- CHECK1(V_A_CP1); + +-- V_A_CP2 := NEW CP'(CONS2_UP); +-- CHECK2(V_A_CP1, V_A_CP2); + + V_A_UP1 := NEW P.UP'(CONS3_UP); + CHECK3(V_A_UP1); + + V_A_UP2 := NEW P.UP'(CONS4_UP); + CHECK4(V_A_UP1, V_A_UP2); + + END; + + RESULT; + +END C48006B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48007a.ada b/gcc/testsuite/ada/acats/tests/c4/c48007a.ada new file mode 100644 index 000000000..7fe88b8a6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48007a.ada @@ -0,0 +1,130 @@ +-- C48007A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T", CHECK THAT CONSTRAINT_ERROR IS +-- RAISED IF T IS AN UNCONSTRAINED TYPE WITH DEFAULT DISCRIMINANTS +-- (RECORD, PRIVATE OR LIMITED) AND ONE DEFAULT DISCRIMINANT VALUE DOES +-- NOT EQUAL THE CORRESPONDING VALUE SPECIFIED FOR THE ALLOCATOR'S BASE +-- TYPE. + +-- EG 08/10/84 + +WITH REPORT; + +PROCEDURE C48007A IS + + USE REPORT; + +BEGIN + + TEST("C48007A","FOR ALLOCATORS OF THE FORM 'NEW T' CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED TYPE WITH " & + "DEFAULT DISCRIMINANTS"); + + DECLARE + + TYPE UR(A : INTEGER := 1; B : INTEGER := 2) IS + RECORD + C : INTEGER := 7; + END RECORD; + + PACKAGE P IS + + TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS + PRIVATE; + TYPE UL(A, B : INTEGER := 4) IS LIMITED PRIVATE; + + PRIVATE + + TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS + RECORD + C : INTEGER := 8; + END RECORD; + TYPE UL(A, B : INTEGER := 4) IS + RECORD + C : INTEGER := 9; + END RECORD; + + END P; + + USE P; + + TYPE A_UR IS ACCESS UR(1, 9); + TYPE A_UP IS ACCESS UP(9, 13); + TYPE A_UL IS ACCESS UL(4, 9); + + VUR : A_UR; + VUP : A_UP; + VUL : A_UL; + + BEGIN + + BEGIN -- UR + + VUR := NEW UR; + FAILED("NO EXCEPTION RAISED - UR"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - UR"); + + END; + + BEGIN -- UP + + VUP := NEW UP; + FAILED("NO EXCEPTION RAISED - UP"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - UP"); + + END; + + BEGIN -- UL + + VUL := NEW UL; + FAILED("NO EXCEPTION RAISED - UL"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - UL"); + + END; + + END; + + RESULT; + +END C48007A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48007b.ada b/gcc/testsuite/ada/acats/tests/c4/c48007b.ada new file mode 100644 index 000000000..117e1677e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48007b.ada @@ -0,0 +1,133 @@ +-- C48007B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T", CHECK THAT CONSTRAINT_ERROR IS +-- RAISED IF T IS A CONSTRAINED TYPE WITH DISCRIMINANTS (RECORD, PRIVATE +-- OR LIMITED) AND AT LEAST ONE DISCRIMINANT VALUE SPECIFIED FOR T DOES +-- NOT EQUAL THE CORRESPONDING VALUE SPECIFIED FOR THE ALLOCATOR'S BASE +-- TYPE. + +-- EG 08/10/84 + +WITH REPORT; + +PROCEDURE C48007B IS + + USE REPORT; + +BEGIN + + TEST("C48007B","FOR ALLOCATORS OF THE FORM 'NEW T' CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - CONSTRAINED TYPE WITH " & + "DISCRIMINANT"); + + DECLARE + + TYPE UR(A, B : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + + PACKAGE P IS + + TYPE UP(A, B : INTEGER) IS PRIVATE; + TYPE UL(A, B : INTEGER) IS LIMITED PRIVATE; + + PRIVATE + + TYPE UP(A, B : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + TYPE UL(A, B : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + + END P; + + USE P; + + SUBTYPE CR IS UR(1, 2); + SUBTYPE CP IS UP(12, 13); + SUBTYPE CL IS UL(4, 4); + + TYPE A_UR IS ACCESS UR(1, 9); + TYPE A_UP IS ACCESS UP(9, 13); + TYPE A_UL IS ACCESS UL(4, 9); + + VUR : A_UR; + VUP : A_UP; + VUL : A_UL; + + BEGIN + + BEGIN -- CR + + VUR := NEW CR; + FAILED("NO EXCEPTION RAISED - CR"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - CR"); + + END; + + BEGIN -- CP + + VUP := NEW CP; + FAILED("NO EXCEPTION RAISED - CP"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - CP"); + + END; + + BEGIN -- CL + + VUL := NEW CL; + FAILED("NO EXCEPTION RAISED - CL"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - CL"); + + END; + + END; + + RESULT; + +END C48007B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48007c.ada b/gcc/testsuite/ada/acats/tests/c4/c48007c.ada new file mode 100644 index 000000000..fff3172d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48007c.ada @@ -0,0 +1,162 @@ +-- C48007C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T", CHECK THAT CONSTRAINT_ERROR IS +-- RAISED IF T IS A CONSTRAINED ARRAY TYPE AND AT LEAST ONE INDEX BOUND +-- FOR T DOES NOT EQUAL THE CORRESPONDING VALUE SPECIFIED FOR THE +-- ALLOCATOR'S BASE TYPE. + +-- EG 08/10/84 + +WITH REPORT; + +PROCEDURE C48007C IS + + USE REPORT; + +BEGIN + + TEST("C48007C","FOR ALLOCATORS OF THE FORM 'NEW T' CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - CONSTRAINED ARRAY TYPE"); + + DECLARE + + TYPE UA1 IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE UA2 IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) OF + INTEGER; + TYPE UA3 IS ARRAY(INTEGER RANGE <>) OF UA1(1 .. 2); + + SUBTYPE CA11 IS UA1(1 .. 3); + SUBTYPE CA12 IS UA1(3 .. 2); + SUBTYPE CA21 IS UA2(1 .. 2, 1 .. 2); + SUBTYPE CA22 IS UA2(1 .. 2, 2 .. 0); + SUBTYPE CA31 IS UA3(1 .. 2); + SUBTYPE CA32 IS UA3(4 .. 1); + + TYPE A_UA11 IS ACCESS UA1(2 .. 4); + TYPE A_UA12 IS ACCESS UA1(4 .. 3); + TYPE A_UA21 IS ACCESS UA2(1 .. 3, 1 .. 2); + TYPE A_UA22 IS ACCESS UA2(1 .. 2, 2 .. 1); + TYPE A_UA31 IS ACCESS UA3(1 .. 3); + TYPE A_UA32 IS ACCESS UA3(3 .. 1); + + V11 : A_UA11; + V12 : A_UA12; + V21 : A_UA21; + V22 : A_UA22; + V31 : A_UA31; + V32 : A_UA32; + + BEGIN + + BEGIN -- V11 + + V11 := NEW CA11; + FAILED("NO EXCEPTION RAISED - V11"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - V11"); + + END; + + BEGIN -- V12 + + V12 := NEW CA12; + FAILED("NO EXCEPTION RAISED - V12"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - V12"); + + END; + + BEGIN -- V21 + + V21 := NEW CA21; + FAILED("NO EXCEPTION RAISED - V21"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - V21"); + + END; + + BEGIN -- V22 + + V22 := NEW CA22; + FAILED("NO EXCEPTION RAISED - V22"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - V22"); + + END; + + BEGIN -- V31 + + V31 := NEW CA31; + FAILED("NO EXCEPTION RAISED - V31"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - V31"); + + END; + + BEGIN -- V32 + + V32 := NEW CA32; + FAILED("NO EXCEPTION RAISED - V32"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - V32"); + + END; + + END; + + RESULT; + +END C48007C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48008a.ada b/gcc/testsuite/ada/acats/tests/c4/c48008a.ada new file mode 100644 index 000000000..19e87aafa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48008a.ada @@ -0,0 +1,345 @@ +-- C48008A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T X", CHECK THAT CONSTRAINT_ERROR IS +-- RAISED IF T IS AN UNCONSTRAINED RECORD, PRIVATE, OR LIMITED TYPE, X +-- IS A DISCRIMINANT CONSTRAINT, AND +-- 1) ONE OF THE VALUES OF X IS OUTSIDE THE RANGE OF THE CORRESPONDING +-- DISCRIMINANT; +-- 2) ONE OF THE DISCRIMINANT VALUES IS NOT COMPATIBLE WITH A +-- CONSTRAINT OF A SUBCOMPONENT IN WHICH IT IS USED; +-- 3) ONE OF THE DISCRIMINANT VALUES DOES NOT EQUAL THE CORRESPONDING +-- VALUE OF THE ALLOCATOR'S BASE TYPE; +-- 4) A DEFAULT INITIALIZATION RAISES AN EXCEPTION. + +-- RM 01/08/80 +-- NL 10/13/81 +-- SPS 10/26/82 +-- JBG 03/02/83 +-- EG 07/05/84 +-- PWB 02/05/86 CORRECTED TEST ERROR: +-- CHANGED "FAILED" TO "COMMENT" IN PROCEDURE INCR_CHECK, +-- SO AS NOT TO PROHIBIT EVAL OF DEFLT EXPR (AI-00397/01) +-- ADDED COMMENTS FOR CASES. + +WITH REPORT; + +PROCEDURE C48008A IS + + USE REPORT; + +BEGIN + + TEST( "C48008A" , "FOR ALLOCATORS OF THE FORM 'NEW T X', " & + "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED RECORD AND " & + "PRIVATE TYPES"); + + DECLARE + + DISC_FLAG : BOOLEAN := FALSE; + INCR_VAL : INTEGER; + FUNCTION INCR(A : INTEGER) RETURN INTEGER; + + SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7); + SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10); + SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9); + + TYPE REC (A : I2_9) IS + RECORD + B : INTEGER := INCR(2); + END RECORD; + + TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER; + + TYPE T_REC (C : I1_10) IS + RECORD + D : REC(C); + END RECORD; + + TYPE T_ARR (C : I1_10) IS + RECORD + D : ARR(2..C); + E : ARR(C..9); + END RECORD; + + TYPE T_REC_REC (A : I1_10) IS + RECORD + B : T_REC(A); + END RECORD; + + TYPE T_REC_ARR (A : I1_10) IS + RECORD + B : T_ARR(A); + END RECORD; + + TYPE TB ( A : I1_7 ) IS + RECORD + R : INTEGER := INCR(1); + END RECORD; + + TYPE UR (A : INTEGER) IS + RECORD + B : I2_9 := INCR(1); + END RECORD; + + TYPE A_T_REC_REC IS ACCESS T_REC_REC; + TYPE A_T_REC_ARR IS ACCESS T_REC_ARR; + TYPE ATB IS ACCESS TB; + TYPE ACTB IS ACCESS TB(3); + TYPE A_UR IS ACCESS UR; + + VA_T_REC_REC : A_T_REC_REC; + VA_T_REC_ARR : A_T_REC_ARR; + VB : ATB; + VCB : ACTB; + V_A_UR : A_UR; + + BOOL : BOOLEAN; + + FUNCTION DISC (A : INTEGER) RETURN INTEGER; + + + PACKAGE P IS + TYPE PRIV( A : I1_10 := DISC(8) ) IS PRIVATE; + CONS_PRIV : CONSTANT PRIV; + PRIVATE + TYPE PRIV( A : I1_10 := DISC(8) ) IS + RECORD + R : INTEGER := INCR(1); + END RECORD; + CONS_PRIV : CONSTANT PRIV := (2, 3); + END P; + + TYPE A_PRIV IS ACCESS P.PRIV; + TYPE A_CPRIV IS ACCESS P.PRIV (3); + + VP : A_PRIV; + VCP : A_CPRIV; + + PROCEDURE PREC_REC (X : A_T_REC_REC) IS + BEGIN + NULL; + END PREC_REC; + + PROCEDURE PREC_ARR (X : A_T_REC_ARR) IS + BEGIN + NULL; + END PREC_ARR; + + PROCEDURE PB (X : ATB) IS + BEGIN + NULL; + END PB; + + PROCEDURE PCB (X : ACTB) IS + BEGIN + NULL; + END PCB; + + PROCEDURE PPRIV (X : A_PRIV) IS + BEGIN + NULL; + END PPRIV; + + PROCEDURE PCPRIV (X : A_CPRIV) IS + BEGIN + NULL; + END PCPRIV; + + FUNCTION DISC (A : INTEGER) RETURN INTEGER IS + BEGIN + DISC_FLAG := TRUE; + RETURN A; + END DISC; + + FUNCTION INCR(A : INTEGER) RETURN INTEGER IS + BEGIN + INCR_VAL := IDENT_INT(INCR_VAL+1); + RETURN A; + END INCR; + + PROCEDURE INCR_CHECK(CASE_ID : STRING) IS + BEGIN + IF INCR_VAL /= IDENT_INT(0) THEN + COMMENT ("DEFAULT INITIAL VALUE WAS EVALUATED - " & + "CASE " & CASE_ID); + END IF; + END INCR_CHECK; + + BEGIN + + BEGIN -- A1A: 0 ILLEGAL FOR TB.A. + INCR_VAL := 0; + VB := NEW TB (A => 0); + FAILED ("NO EXCEPTION RAISED - CASE A1A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A1A"); + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE A1A" ); + END; -- A1A + + BEGIN -- A1B: 8 ILLEGAL IN I1_7. + INCR_VAL := 0; + VB := NEW TB (A => I1_7'(IDENT_INT(8))); + FAILED ("NO EXCEPTION RAISED - CASE A1B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A1B"); + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE A1B"); + END; -- A1B + + BEGIN -- A1C: 8 ILLEGAL FOR TB.A. + INCR_VAL := 0; + PB(NEW TB (A => 8)); + FAILED ("NO EXCEPTION RAISED - CASE A1C"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A1C"); + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE A1C"); + END; --A1C + + BEGIN --A1D: 0 ILLEGAL FOR TB.A. + INCR_VAL := 0; + BOOL := ATB'(NEW TB(A => 0)) = NULL; + FAILED ("NO EXCEPTION RAISED - CASE A1D"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A1D"); + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE A1D"); + END; --A1D + + BEGIN --A1E: 11 ILLEGAL FOR PRIV.A. + DISC_FLAG := FALSE; + INCR_VAL := 0; + VP := NEW P.PRIV(11); + FAILED("NO EXCEPTION RAISED - CASE A1E"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF DISC_FLAG THEN + FAILED ("DISCR DEFAULT EVALUATED WHEN " & + "EXPLICIT VALUE WAS PROVIDED - A1E"); + END IF; + INCR_CHECK("A1E"); + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - CASE A1E"); + END; -- A1E + + BEGIN -- A2A: 1 ILLEGAL FOR REC.A. + INCR_VAL := 0; + VA_T_REC_REC := NEW T_REC_REC(A => I1_10'(IDENT_INT(1))); + FAILED ("NO EXCEPTION RAISED - CASE A2A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A2A"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A2A"); + END; -- A2A + + BEGIN --A2B: 10 ILLEGAL FOR REC.A. + INCR_VAL := 0; + VA_T_REC_REC := NEW T_REC_REC (10); + FAILED ("NO EXCEPTION RAISED - CASE A2B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A2B"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A2B"); + END; -- A2B + + BEGIN -- A2C: 1 ILLEGAL FOR T.ARR.E'FIRST. + INCR_VAL := 0; + PREC_ARR (NEW T_REC_ARR (1)); + FAILED ("NO EXCEPTION RAISED - CASE A2C"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK ("A2C"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A2C"); + END; -- A2C + + BEGIN -- A2D: 10 ILLEGAL FOR T_ARR.D'LAST. + INCR_VAL := 0; + BOOL := NEW T_REC_ARR (IDENT_INT(10)) = NULL; + FAILED ("NO EXCEPTION RAISED - CASE A2D"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK ("A2D"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A2D"); + END; -- A2D + + BEGIN -- A3A: ASSIGNMENT VIOLATES CONSTRAINT ON VCB'S SUBTYPE. + INCR_VAL := 0; + VCB := NEW TB (4); + FAILED ("NO EXCEPTION RAISED - CASE A3A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A3A"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A3A"); + END; -- A3A + + BEGIN -- A3B: PARM ASSOC VIOLATES CONSTRAINT ON PARM SUBTYPE. + INCR_VAL := 0; + PCB (NEW TB (4)); + FAILED ("NO EXCEPTION RAISED - CASE A3B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A3B"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A3B"); + END; -- A3B + + BEGIN -- A3C: 2 VIOLATES CONSTRAINT ON SUBTYPE ACTB. + INCR_VAL := 0; + BOOL := ACTB'(NEW TB (IDENT_INT(2))) = NULL; + FAILED ("NO EXCEPTION RAISED - CASE A3C"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A3C"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A3C"); + END; -- A3C + + BEGIN -- A4A: EVALUATION OF DEFAULT RAISES EXCEPTION. + INCR_VAL := 0; + V_A_UR := NEW UR(4); + FAILED ("NO EXCEPTION RAISED - CASE A4A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A4A"); + END; -- A4A + + END; + + RESULT; + +END C48008A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48008c.ada b/gcc/testsuite/ada/acats/tests/c4/c48008c.ada new file mode 100644 index 000000000..39f564d57 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48008c.ada @@ -0,0 +1,79 @@ +-- C48008C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T X", CHECK THAT CONSTRAINT_ERROR IS +-- RAISED IF T IS AN UNCONSTRAINED ARRAY TYPE WITH INDEX SUBTYPE(S) S, X +-- IS AN INDEX CONSTRAINT, AND THE BOUNDS OF X ARE NOT COMPATIBLE WITH +-- AN INDEX SUBTYPE OF T. + +-- RM 01/08/80 +-- NL 10/13/81 +-- EG 07/05/84 + +WITH REPORT; + +PROCEDURE C48008C IS + + USE REPORT; + +BEGIN + + TEST("C48008C","FOR ALLOCATORS OF THE FORM 'NEW T X', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED ARRAY TYPE"); + + DECLARE + + SUBTYPE TWO IS INTEGER RANGE 1..2; + TYPE TF IS ARRAY( TWO RANGE <> , TWO RANGE <> ) OF INTEGER; + TYPE ATF IS ACCESS TF; + VF : ATF; + + BEGIN + + BEGIN + VF := NEW TF ( 0..1 , 1..2 ); + FAILED ("NO EXCEPTION RAISED - CASE 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 1"); + END; + + BEGIN + VF := NEW TF(1 .. 2, 2 .. IDENT_INT(3)); + FAILED ("NO EXCEPTION RAISED - CASE 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2"); + END; + + END; + + RESULT; + +END C48008C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009a.ada b/gcc/testsuite/ada/acats/tests/c4/c48009a.ada new file mode 100644 index 000000000..fa0d4075a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009a.ada @@ -0,0 +1,104 @@ +-- C48009A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR +-- IS RAISED IF T IS A SCALAR SUBTYPE AND X IS OUTSIDE THE RANGE OF T, +-- OR IS WITHIN T'S RANGE AND OUTSIDE OF THE RANGE OF VALUES PERMITTED +-- FOR OBJECTS DESIGNATED BY VALUES OF THE ALLOCATOR'S BASE TYPE. + +-- RM 01/08/80 +-- NL 10/13/81 +-- SPS 10/26/82 +-- JBG 03/02/83 +-- EG 07/05/84 +-- EDS 12/01/97 ADDED IDENT_INT TO MAKE EXPRESSION NON-STATIC. + +WITH REPORT; + +PROCEDURE C48009A IS + + USE REPORT; + +BEGIN + + TEST( "C48009A" , "FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK" & + " THAT CONSTRAINT_ERROR IS RAISED WHEN" & + " APPROPRIATE - SCALAR TYPES"); + DECLARE -- A1 + + SUBTYPE TA IS INTEGER RANGE 1..7; + TYPE ATA IS ACCESS TA; + VA : ATA; + + BEGIN + + VA := NEW TA'( IDENT_INT(0) ); + FAILED ("NO EXCEPTION RAISED - 1"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ( "WRONG EXCEPTION RAISED - 1" ); + + END; -- A1 + + DECLARE -- A2 + + SUBTYPE T1_7 IS INTEGER RANGE 1..7; + TYPE AT2_6 IS ACCESS INTEGER RANGE 2..6; + VAT2_6 : AT2_6; + + BEGIN + + BEGIN + + VAT2_6 := NEW T1_7'(1); + FAILED ("NO EXCEPTION RAISED - 2"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + + END; + + BEGIN + + VAT2_6 := NEW T1_7'(7); + FAILED ("NO EXCEPTION RAISED - 3"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 3"); + + END; + + END; -- A2 + + RESULT; + +END C48009A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009b.ada b/gcc/testsuite/ada/acats/tests/c4/c48009b.ada new file mode 100644 index 000000000..d74d90249 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009b.ada @@ -0,0 +1,255 @@ +-- C48009B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR +-- IS RAISED IF T IS AN UNCONSTRAINED RECORD OR PRIVATE TYPE, (X) IS AN +-- AGGREGATE OR A VALUE OF TYPE T, AND ONE OF THE DISCRIMINANT VALUES IN +-- X: +-- 1) DOES NOT SATISFY THE RANGE CONSTRAINT FOR THE CORRESPONDING +-- DISCRIMINANT OF T. +-- 2) DOES NOT EQUAL THE DISCRIMINANT VALUE SPECIFIED IN THE +-- DECLARATION OF THE ALLOCATOR'S BASE TYPE. +-- 3) A DISCRIMINANT VALUE IS COMPATIBLE WITH A DISCRIMINANT'S SUBTYPE +-- BUT DOES NOT PROVIDE A COMPATIBLE INDEX OR DISCRIMINANT +-- CONSTRAINT FOR A SUBCOMPONENT DEPENDENT ON THE DISCRIMINANT. + +-- RM 01/08/80 +-- NL 10/13/81 +-- SPS 10/26/82 +-- JBG 03/02/83 +-- EG 07/05/84 + +WITH REPORT; + +PROCEDURE C48009B IS + + USE REPORT; + +BEGIN + + TEST( "C48009B" , "FOR ALLOCATORS OF THE FORM 'NEW T '(X)', " & + "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED RECORD AND " & + "PRIVATE TYPES"); + + DECLARE + + SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7); + SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10); + SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9); + + TYPE REC (A : I2_9) IS + RECORD + NULL; + END RECORD; + + TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER; + + TYPE T_REC (C : I1_10) IS + RECORD + D : REC(C); + END RECORD; + + TYPE T_ARR (C : I1_10) IS + RECORD + D : ARR(2..C); + E : ARR(C..9); + END RECORD; + + TYPE T_REC_REC (A : I1_10) IS + RECORD + B : T_REC(A); + END RECORD; + + TYPE T_REC_ARR (A : I1_10) IS + RECORD + B : T_ARR(A); + END RECORD; + + TYPE TB ( A : I1_7 ) IS + RECORD + R : INTEGER; + END RECORD; + + TYPE A_T_REC_REC IS ACCESS T_REC_REC; + TYPE A_T_REC_ARR IS ACCESS T_REC_ARR; + TYPE ATB IS ACCESS TB; + TYPE ACTB IS ACCESS TB(3); + + VA_T_REC_REC : A_T_REC_REC; + VA_T_REC_ARR : A_T_REC_ARR; + VB : ATB; + VCB : ACTB; + + PACKAGE P IS + TYPE PRIV( A : I1_10 ) IS PRIVATE; + CONS_PRIV : CONSTANT PRIV; + PRIVATE + TYPE PRIV( A : I1_10 ) IS + RECORD + R : INTEGER; + END RECORD; + CONS_PRIV : CONSTANT PRIV := (2, 3); + END P; + + USE P; + + TYPE A_PRIV IS ACCESS P.PRIV; + TYPE A_CPRIV IS ACCESS P.PRIV (3); + + VP : A_PRIV; + VCP : A_CPRIV; + + FUNCTION ALLOC1(X : P.PRIV) RETURN A_CPRIV IS + BEGIN + IF EQUAL(1, 1) THEN + RETURN NEW P.PRIV'(X); + ELSE + RETURN NULL; + END IF; + END ALLOC1; + FUNCTION ALLOC2(X : TB) RETURN ACTB IS + BEGIN + IF EQUAL(1, 1) THEN + RETURN NEW TB'(X); + ELSE + RETURN NULL; + END IF; + END ALLOC2; + + BEGIN + + BEGIN -- B1 + VB := NEW TB'(A => IDENT_INT(0), R => 1); + FAILED ("NO EXCEPTION RAISED - CASE 1A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE 1A" ); + END; + + BEGIN + VB := NEW TB'(A => 8, R => 1); + FAILED ("NO EXCEPTION RAISED - CASE 1B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE 1B"); + END; -- B1 + + BEGIN -- B2 + VCB := NEW TB'(2, 3); + FAILED ("NO EXCEPTION RAISED - CASE 2A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2A"); + END; + + BEGIN + IF ALLOC2((IDENT_INT(4), 3)) = NULL THEN + FAILED ("IMPOSSIBLE - CASE 2B"); + END IF; + FAILED ("NO EXCEPTION RAISED - CASE 2B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2B"); + END; + + BEGIN + + IF ALLOC1(CONS_PRIV) = NULL THEN + FAILED ("IMPOSSIBLE - CASE 2C"); + END IF; + FAILED ("NO EXCEPTION RAISED - CASE 2C"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2C"); + + END; -- B2 + + BEGIN -- B3 + + VA_T_REC_REC := NEW T_REC_REC'(1, (1, (A => 1))); + FAILED ("NO EXCEPTION RAISED - CASE 3A"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3A"); + + END; + + BEGIN + + VA_T_REC_REC := NEW T_REC_REC'(10, + (10, (A => 10))); + FAILED ("NO EXCEPTION RAISED - CASE 3B"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3B"); + + END; + + BEGIN + + VA_T_REC_ARR := NEW T_REC_ARR'(1, (1, (OTHERS => 1), + (OTHERS => 2))); + FAILED ("NO EXCEPTION RAISED - CASE 3C"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3C"); + + END; + + BEGIN + + VA_T_REC_ARR := NEW T_REC_ARR'(10, (10, (OTHERS => 1), + (OTHERS => 2))); + FAILED ("NO EXCEPTION RAISED - CASE 3D"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3D"); + + END; + + END; + + RESULT; + +END C48009B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009c.ada b/gcc/testsuite/ada/acats/tests/c4/c48009c.ada new file mode 100644 index 000000000..80d18f342 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009c.ada @@ -0,0 +1,113 @@ +-- C48009C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR +-- IS RAISED IF T IS A CONSTRAINED RECORD OR PRIVATE TYPE, (X) IS AN +-- AGGREGATE OR A VALUE OF TYPE T, AND ONE OF THE DISCRIMINANT VALUES IN +-- X: +-- 1) DOES NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE FOR T. +-- 2) DOES NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE SPECIFIED +-- IN THE DECLARATION OF THE ALLOCATOR'S BASE TYPE. +-- 3) DOES NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE IN THE +-- ACCESS TO ACCESS CASE. + +-- RM 01/08/80 +-- NL 10/13/81 +-- SPS 10/26/82 +-- EG 07/05/84 + +WITH REPORT; + +PROCEDURE C48009C IS + + USE REPORT; + +BEGIN + + TEST("C48009C","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - CONSTRAINED RECORD TYPES"); + + DECLARE + + TYPE TC0(A, B : INTEGER) IS + RECORD + C : INTEGER RANGE 1 .. 7; + END RECORD; + SUBTYPE TC IS TC0(2, 3); + TYPE ATC IS ACCESS TC0(2, 3); + SUBTYPE TC4_5 IS TC0(IDENT_INT(4), IDENT_INT(5)); + VC : ATC; + + BEGIN + + BEGIN + VC := NEW TC'(102, 3, 4); + FAILED ("NO EXCEPTION RAISED - CASE 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - CASE 1"); + END; + + BEGIN + VC := NEW TC4_5'(IDENT_INT(4), IDENT_INT(5), 1); + FAILED ("NO EXCEPTION RAISED - CASE 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - CASE 2"); + END; + + END; + + DECLARE + + TYPE UR(A : INTEGER) IS + RECORD + NULL; + END RECORD; + TYPE A_UR IS ACCESS UR; + SUBTYPE CA_UR IS A_UR(2); + TYPE A_CA_UR IS ACCESS CA_UR; + + V : A_CA_UR; + + BEGIN + + V := NEW CA_UR'(NEW UR'(A => IDENT_INT(3))); + FAILED ("NO EXCEPTION RAISED - CASE 3"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3"); + + END; + + RESULT; + +END C48009C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009d.ada b/gcc/testsuite/ada/acats/tests/c4/c48009d.ada new file mode 100644 index 000000000..0c5d3d647 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009d.ada @@ -0,0 +1,128 @@ +-- C48009D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR +-- IS RAISED IF T IS AN UNCONSTRAINED ARRAY TYPE WITH INDEX SUBTYPE(S) +-- S, +-- 1) X HAS TOO MANY VALUES FOR S; +-- 2) A NAMED NON-NULL BOUND OF X LIES OUTSIDE S'S RANGE; +-- 3) THE BOUND'S OF X ARE NOT EQUAL TO BOUNDS SPECIFIED FOR THE +-- ALLOCATOR'S DESIGNATED BASE TYPE. (THEY ARE EQUAL TO THE BOUNDS +-- SPECIFIED FOR T). + +-- RM 01/08/80 +-- NL 10/13/81 +-- SPS 10/26/82 +-- JBG 03/03/83 +-- EG 07/05/84 +-- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X. +-- KAS 11/14/95 FOR SLIDING ASSIGNMENT, CHANGED FAIL TO COMMENT ON LANGUAGE +-- KAS 12/02/95 INCLUDED SECOND CASE +-- PWN 05/03/96 Enforced Ada 95 sliding rules + +WITH REPORT; + +PROCEDURE C48009D IS + + USE REPORT ; + +BEGIN + + TEST("C48009D","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED ARRAY TYPES"); + DECLARE + + SUBTYPE TWO IS INTEGER RANGE 1 .. 2; + SUBTYPE TWON IS INTEGER RANGE IDENT_INT(1) .. IDENT_INT(2); + TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE TD IS ARRAY(TWO RANGE <>) OF INTEGER RANGE 1 .. 7; + TYPE TDN IS ARRAY(TWON RANGE <>) OF INTEGER RANGE 1 .. 7; + TYPE ATD IS ACCESS TD; + TYPE ATDN IS ACCESS TDN; + TYPE A_UA IS ACCESS UA; + TYPE A_CA IS ACCESS UA(3 .. 4); + TYPE A_CAN IS ACCESS UA(4 .. 3); + VD : ATD; + VDN : ATDN; + V_A_CA : A_CA; + V_A_CAN : A_CAN; + + BEGIN + + BEGIN + VD := NEW TD'(3, 4, 5); + FAILED ("NO EXCEPTION RAISED - CASE 1A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 1A"); + END; + + BEGIN + VDN := NEW TDN'(3, 4, 5); + FAILED ("NO EXCEPTION RAISED - CASE 1B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 1B"); + END; + + BEGIN + VD := NEW TD'(IDENT_INT(0) .. 2 => 6); + FAILED ("NO EXCEPTION RAISED - CASE 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2"); + END; + + BEGIN + V_A_CA := NEW UA'(2 .. 3 => 3); + COMMENT ("ADA 95 SLIDING ASSIGNMENT - CASE 3A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("ADA 83 NON SLIDING ASSIGNMENT - CASE 3A"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3A"); + END; + + BEGIN + V_A_CAN := NEW UA'(IDENT_INT(3) .. IDENT_INT(2) => 3); + COMMENT ("ADA 95 SLIDING ASSIGNMENT - CASE 3B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("ADA 83 NON SLIDING ASSIGNMENT - CASE 3B"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3B"); + END; + + END; + + RESULT; + +END C48009D; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009e.ada b/gcc/testsuite/ada/acats/tests/c4/c48009e.ada new file mode 100644 index 000000000..e27319249 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009e.ada @@ -0,0 +1,224 @@ +-- C48009E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR +-- IS RAISED IF T IS A CONSTRAINED ARRAY TYPE AND: +-- 1) A NAMED NULL OR NON-NULL BOUND FOR X DOES NOT EQUAL THE +-- CORRESPONDING BOUND FOR T; +-- 2) A BOUND OF T DOES NOT EQUAL THE CORRESPONDING VALUE SPECIFIED IN +-- THE DECLARATION OF THE ALLOCATOR'S BASE TYPE; +-- 3) A POSITIONAL AGGREGATE DOES NOT HAVE THE NUMBER OF COMPONENTS +-- REQUIRED BY T OR BY THE ALLOCATOR'S BASE TYPE. + + -- RM 01/08/80 + -- NL 10/13/81 + -- SPS 10/26/82 + -- JBG 03/03/83 + -- EG 07/05/84 + -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X. + -- KAS 11/14/95 CHANGED FAILURE AT SLIDING ASSIGNMENT TO COMMENT ON LANGUAGE + -- KAS 11/30/95 REINSTRUMENTED CASES TO SELECT LANGUAGE SEMANTICS + -- PWN 05/03/96 Enforced Ada 95 sliding rules + -- PWN 10/24/96 Adjusted expected results for Ada 95. + -- TMB 11/19/96 BACKED OUT CHANGE FOR SLIDING WITH ACCESS TYPES + -- MRM 12/16/96 Removed problem code from withdrawn version of test, and + -- implemented a dereference-index check to ensure Ada95 + -- required behavior. + -- PWB.CTA 03/07/97 Restored checks from 1.11 in 2 cases where sliding does + -- not occur + WITH REPORT; + + PROCEDURE C48009E IS + + USE REPORT ; + + BEGIN + + TEST("C48009E","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - CONSTRAINED ARRAY TYPES"); + DECLARE + + TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE CA3_2 IS ARRAY(3 .. 2) OF INTEGER; + TYPE SA1_3 IS ARRAY(1 .. 3) OF INTEGER; + TYPE NA1_3 IS ARRAY(1 .. IDENT_INT(3)) OF INTEGER; + SUBTYPE CA2_6 IS UA(2 .. 6); + SUBTYPE CA1_4 IS UA(1 .. 4); + SUBTYPE CA1_6 IS UA(1 .. 6); + SUBTYPE CA4_1 IS UA(4 .. 1); + SUBTYPE CA4_2 IS UA(4 .. 2); + + TYPE A_CA3_2 IS ACCESS CA3_2; + TYPE A_SA1_3 IS ACCESS SA1_3; + TYPE A_NA1_3 IS ACCESS NA1_3; + TYPE A_CA1_5 IS ACCESS UA(1 .. 5); + TYPE A_CA4_2 IS ACCESS CA4_2; + + V_A_CA3_2 : A_CA3_2; + V_A_SA1_3 : A_SA1_3; + V_A_NA1_3 : A_NA1_3; + V_A_CA1_5 : A_CA1_5; + + FUNCTION ALLOC1(X : CA2_6) RETURN A_CA1_5 IS + BEGIN + IF EQUAL(1, 1) THEN + RETURN NEW CA2_6'(X); + ELSE + RETURN NULL; + END IF; + END ALLOC1; + FUNCTION ALLOC2(X : CA4_1) RETURN A_CA4_2 IS + BEGIN + IF EQUAL(1, 1) THEN + RETURN NEW CA4_1'(X); + ELSE + RETURN NULL; + END IF; + END ALLOC2; + + BEGIN + + BEGIN + V_A_CA3_2 := NEW CA3_2'(IDENT_INT(4) .. IDENT_INT(2) + => 5); + FAILED ("NO EXCEPTION RAISED - CASE 1A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 1A"); + END; + + BEGIN + V_A_NA1_3 := NEW NA1_3'(1 .. IDENT_INT(2) => 4); + FAILED ("NO EXCEPTION RAISED - CASE 1B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 1B"); + END; + + BEGIN + -- note that ALLOC1 returns A_CA1_5, so both + -- (1) and (5) are valid index references! + IF ALLOC1((2 .. 6 => 2))(5) /= 2 THEN + FAILED ("Wrong Value Returned - CASE 2A"); + ELSIF ALLOC1((2 .. 6 => 3))(1) /= 3 THEN + FAILED ("Unlikely Index Case - CASE 2A"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - CASE 2A"); + END; + + BEGIN + IF ALLOC2((4 .. 1 => 3)) = NULL THEN + FAILED ("IMPOSSIBLE - CASE 2B"); + END IF; + COMMENT ("ADA 95 SLIDING ASSIGNMENT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("ADA 83 NON-SLIDING ASSIGNMENT"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2B"); + END; + + BEGIN + V_A_SA1_3 := NEW SA1_3'(1, 2); + FAILED ("NO EXCEPTION RAISED - CASE 3A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3A"); + END; + + BEGIN + V_A_SA1_3 := NEW SA1_3'(3, 4, 5, 6); + FAILED ("NO EXCEPTION RAISED - CASE 3B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3B"); + END; + + BEGIN + V_A_NA1_3 := NEW NA1_3'(1, 2); + FAILED ("NO EXCEPTION RAISED - CASE 3C"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3C"); + END; + + BEGIN -- SATISFIES T BUT NOT BASE TYPE. + V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4); + FAILED ("NO EXCEPTION RAISED - CASE 3D"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3D"); + END; + + BEGIN -- SATISFIES T BUT NOT BASE TYPE. + V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5, 6); + FAILED ("NO EXCEPTION RAISED - CASE 3E"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3E"); + END; + + BEGIN -- SATISFIES BASE TYPE BUT NOT T. + V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4, 5); + FAILED ("NO EXCEPTION RAISED - CASE 3F"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3F"); + END; + + BEGIN -- SATISFIES BASE TYPE BUT NOT T. + V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5); + FAILED ("NO EXCEPTION RAISED - CASE 3G"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3G"); + END; + + END ; + + RESULT ; + + END C48009E ; + diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009f.ada b/gcc/testsuite/ada/acats/tests/c4/c48009f.ada new file mode 100644 index 000000000..d02e2c1fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009f.ada @@ -0,0 +1,99 @@ +-- C48009F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR +-- IS RAISED IF T IS A CONSTRAINED OR UNCONSTRAINED MULTI-DIMENSIONAL +-- ARRAY TYPE AND ALL COMPONENTS OF X DO NOT HAVE THE SAME LENGTH OR +-- BOUNDS. + +-- RM 01/08/80 +-- NL 10/13/81 +-- SPS 10/26/82 +-- JBG 03/03/83 +-- EG 07/05/84 + +WITH REPORT; + +PROCEDURE C48009F IS + + USE REPORT; + +BEGIN + + TEST("C48009F","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "X IS AN ILL-FORMED MULTIDIMENSIONAL AGGREGATE"); + + DECLARE + + TYPE TG00 IS ARRAY( 4..2 ) OF INTEGER; + TYPE TG10 IS ARRAY( 1..2 ) OF INTEGER; + TYPE TG20 IS ARRAY( INTEGER RANGE <> ) OF INTEGER; + + TYPE TG0 IS ARRAY( 3..2 ) OF TG00; + TYPE TG1 IS ARRAY( 1..2 ) OF TG10; + TYPE TG2 IS ARRAY( INTEGER RANGE <> ) OF TG20(1..3); + + TYPE ATG0 IS ACCESS TG0; + TYPE ATG1 IS ACCESS TG1; + TYPE ATG2 IS ACCESS TG2; + + VG0 : ATG0; + VG1 : ATG1; + VG2 : ATG2; + + BEGIN + + BEGIN + VG0 := NEW TG0 '( 5..4 => ( 3..1 => 2 ) ); + FAILED ("NO EXCEPTION RAISED - CASE 0"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE 0" ); + END; + + BEGIN + VG1 := NEW TG1 '( ( 1 , 2 ) , ( 3 , 4 , 5 ) ); + FAILED ("NO EXCEPTION RAISED - CASE 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE 1" ); + END; + + BEGIN + VG2 := NEW TG2'( 1 => ( 1..2 => 7) , 2 => ( 1..3 => 7)); + FAILED ("NO EXCEPTION RAISED - CASE 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE 2" ); + END; + + END; + + RESULT; + +END C48009F; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009g.ada b/gcc/testsuite/ada/acats/tests/c4/c48009g.ada new file mode 100644 index 000000000..13fec942f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009g.ada @@ -0,0 +1,209 @@ +-- C48009G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT +-- CONSTRAINT_ERROR IS RAISED IF T IS A CONSTRAINED ACCESS +-- TYPE AND THE OBJECT DESIGNATED BY X DOES NOT HAVE DISCRIMINANTS +-- OR INDEX BOUNDS THAT EQUAL THE CORRESPONDING VALUES FOR T. + +-- HISTORY: +-- EG 08/30/84 CREATED ORIGINAL TEST. +-- JET 01/05/87 UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT +-- OPTIMIZATION. + +WITH REPORT; + +PROCEDURE C48009G IS + + USE REPORT; + + GENERIC + TYPE G_TYPE IS PRIVATE; + FUNCTION EQUAL_G (X : G_TYPE; Y : G_TYPE) RETURN BOOLEAN; + + FUNCTION EQUAL_G (X : G_TYPE; Y : G_TYPE) RETURN BOOLEAN IS + BEGIN + IF (IDENT_INT(3) = 3) AND (X = Y) THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; + END EQUAL_G; + +BEGIN + + TEST("C48009G","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - CONSTRAINED ACCESS TYPE"); + + DECLARE + + TYPE INT IS RANGE 1 .. 5; + + TYPE UR(A : INT) IS + RECORD + B : INTEGER; + END RECORD; + TYPE UA IS ARRAY(INT RANGE <>) OF INTEGER; + + PACKAGE P IS + TYPE UP(A, B : INT) IS PRIVATE; + TYPE UL(A, B : INT) IS LIMITED PRIVATE; + CONS_UP : CONSTANT UP; + PRIVATE + TYPE UP(A, B : INT) IS + RECORD + C : INTEGER; + END RECORD; + TYPE UL(A, B : INT) IS + RECORD + C : INTEGER; + END RECORD; + CONS_UP : CONSTANT UP := (2, 2, (IDENT_INT(3))); + END P; + + TYPE A_UR IS ACCESS UR; + TYPE A_UA IS ACCESS UA; + TYPE A_UP IS ACCESS P.UP; + TYPE A_UL IS ACCESS P.UL; + + SUBTYPE CA_UR IS A_UR(2); + SUBTYPE CA_UA IS A_UA(2 .. 3); + SUBTYPE CA_UP IS A_UP(3, 2); + SUBTYPE CA_UL IS A_UL(2, 4); + + TYPE A_CA_UR IS ACCESS CA_UR; + TYPE A_CA_UA IS ACCESS CA_UA; + TYPE A_CA_UP IS ACCESS CA_UP; + TYPE A_CA_UL IS ACCESS CA_UL; + + V_A_CA_UR : A_CA_UR; + V_A_CA_UA : A_CA_UA; + V_A_CA_UP : A_CA_UP; + V_A_CA_UL : A_CA_UL; + + FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UR); + FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UA); + FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UP); + FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UL); + + BEGIN + + BEGIN + V_A_CA_UR := NEW CA_UR'(NEW UR'(1,(IDENT_INT(2)))); + + IF EQUAL (V_A_CA_UR, V_A_CA_UR) THEN + FAILED ("NO EXCEPTION RAISED - UR"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UR"); + END; + + BEGIN + V_A_CA_UA := NEW CA_UA'(NEW UA'(1 => 2, + 2 => IDENT_INT(3))); + + IF EQUAL (V_A_CA_UA, V_A_CA_UA) THEN + FAILED ("NO EXCEPTION RAISED - UA"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UA"); + END; + + BEGIN + V_A_CA_UP := NEW CA_UP'(NEW P.UP'(P.CONS_UP)); + + IF EQUAL (V_A_CA_UP, V_A_CA_UP) THEN + FAILED ("NO EXCEPTION RAISED - UP"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UP"); + END; + + BEGIN + V_A_CA_UR := NEW CA_UR'(NULL); + + IF NOT EQUAL (V_A_CA_UR, V_A_CA_UR) THEN + COMMENT ("NO EXCEPTION RAISED - UR"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - UR"); + END; + + BEGIN + V_A_CA_UA := NEW CA_UA'(NULL); + + IF NOT EQUAL (V_A_CA_UA, V_A_CA_UA) THEN + COMMENT ("NO EXCEPTION RAISED - UA"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - UA"); + END; + + BEGIN + V_A_CA_UP := NEW CA_UP'(NULL); + + IF NOT EQUAL (V_A_CA_UP, V_A_CA_UP) THEN + COMMENT ("NO EXCEPTION RAISED - UP"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - UP"); + END; + + BEGIN + V_A_CA_UL := NEW CA_UL'(NULL); + + IF NOT EQUAL (V_A_CA_UL, V_A_CA_UL) THEN + COMMENT ("NO EXCEPTION RAISED - UL"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - UL"); + END; + + END; + + RESULT; + +END C48009G; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009h.ada b/gcc/testsuite/ada/acats/tests/c4/c48009h.ada new file mode 100644 index 000000000..661793be3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009h.ada @@ -0,0 +1,129 @@ +-- C48009H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR +-- IS RAISED IF T IS AN (UNCONSTRAINED) ACCESS TYPE, THE DESIGNATED TYPE +-- FOR T'BASE IS CONSTRAINED, AND THE OBJECT DESIGNATED BY X DOES NOT +-- HAVE DISCRIMINANTS OR INDEX BOUNDS THAT EQUAL THE CORRESPONDING +-- VALUES FOR T'S DESIGNATED TYPE. + +-- EG 08/30/84 + +WITH REPORT; + +PROCEDURE C48009H IS + + USE REPORT; + +BEGIN + + TEST("C48009H","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED ACCESS TYPE OF A " & + "CONSTRAINED TYPE"); + + DECLARE + + TYPE UR(A : INTEGER) IS + RECORD + NULL; + END RECORD; + TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER; + + PACKAGE P IS + TYPE UP(A : INTEGER) IS PRIVATE; + TYPE UL(A : INTEGER) IS LIMITED PRIVATE; + PRIVATE + TYPE UP(A : INTEGER) IS + RECORD + NULL; + END RECORD; + TYPE UL(A : INTEGER) IS + RECORD + NULL; + END RECORD; + END P; + + TYPE A_CR IS ACCESS UR(IDENT_INT(2)); + TYPE A_CA IS ACCESS UA(2 .. IDENT_INT(4)); + TYPE A_CP IS ACCESS P.UP(3); + TYPE A_CL IS ACCESS P.UL(4); + + TYPE AA_CR IS ACCESS A_CR; + TYPE AA_CA IS ACCESS A_CA; + TYPE AA_CP IS ACCESS A_CP; + TYPE AA_CL IS ACCESS A_CL; + + V_AA_CR : AA_CR; + V_AA_CA : AA_CA; + V_AA_CP : AA_CP; + V_AA_CL : AA_CL; + + BEGIN + + BEGIN + V_AA_CR := NEW A_CR'(NEW UR(3)); + FAILED ("NO EXCEPTION RAISED - CR"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CR"); + END; + + BEGIN + V_AA_CA := NEW A_CA'(NEW UA(IDENT_INT(3) .. 5)); + FAILED ("NO EXCEPTION RAISED - CA"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CA"); + END; + + BEGIN + V_AA_CP := NEW A_CP'(NEW P.UP(IDENT_INT(4))); + FAILED ("NO EXCEPTION RAISED - CP"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CP"); + END; + + BEGIN + V_AA_CL := NEW A_CL'(NEW P.UL(5)); + FAILED ("NO EXCEPTION RAISED - CL"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CL"); + END; + + END; + + RESULT; + +END C48009H; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009i.ada b/gcc/testsuite/ada/acats/tests/c4/c48009i.ada new file mode 100644 index 000000000..d59b4ddb9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009i.ada @@ -0,0 +1,128 @@ +-- C48009I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR +-- IS RAISED IF THE DESIGNATED TYPE FOR "NEW T'(X)" IS A CONSTRAINED +-- ACCESS TYPE, CA, T IS CA'BASE, AND A DISCRIMINANT OR INDEX VALUE OF X +-- DOES NOT EQUAL A VALUE SPECIFIED FOR CA. + +-- EG 08/30/84 + +WITH REPORT; + +PROCEDURE C48009I IS + + USE REPORT; + +BEGIN + + TEST("C48009I","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - ACCESS TYPE OF CONSTRAINED " & + "ACCESS TYPE"); + + DECLARE + + TYPE UR(A : INTEGER) IS + RECORD + NULL; + END RECORD; + TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER; + + PACKAGE P IS + TYPE UP(A : INTEGER) IS PRIVATE; + TYPE UL(A : INTEGER) IS LIMITED PRIVATE; + PRIVATE + TYPE UP(A : INTEGER) IS + RECORD + NULL; + END RECORD; + TYPE UL(A : INTEGER) IS + RECORD + NULL; + END RECORD; + END P; + + TYPE A_UR IS ACCESS UR; + TYPE A_UA IS ACCESS UA; + TYPE A_UP IS ACCESS P.UP; + TYPE A_UL IS ACCESS P.UL; + + TYPE AC_A_UR IS ACCESS A_UR(2); + TYPE AC_A_UA IS ACCESS A_UA(2 .. 4); + TYPE AC_A_UP IS ACCESS A_UP(3); + TYPE AC_A_UL IS ACCESS A_UL(4); + + V_AC_A_UR : AC_A_UR; + V_AC_A_UA : AC_A_UA; + V_AC_A_UP : AC_A_UP; + V_AC_A_UL : AC_A_UL; + + BEGIN + + BEGIN + V_AC_A_UR := NEW A_UR'(NEW UR(3)); + FAILED ("NO EXCEPTION RAISED - UR"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UR"); + END; + + BEGIN + V_AC_A_UA := NEW A_UA'(NEW UA(3 .. 5)); + FAILED ("NO EXCEPTION RAISED - UA"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UA"); + END; + + BEGIN + V_AC_A_UP := NEW A_UP'(NEW P.UP(IDENT_INT(4))); + FAILED ("NO EXCEPTION RAISED - UP"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UP"); + END; + + BEGIN + V_AC_A_UL := NEW A_UL'(NEW P.UL(IDENT_INT(5))); + FAILED ("NO EXCEPTION RAISED - UL"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UL"); + END; + + END; + + RESULT; + +END C48009I; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48009j.ada b/gcc/testsuite/ada/acats/tests/c4/c48009j.ada new file mode 100644 index 000000000..c384f38b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009j.ada @@ -0,0 +1,132 @@ +-- C48009J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR +-- IS RAISED IF T IS AN UNCONSTRAINED ACCESS TYPE, ITS DESIGNATED TYPE +-- IS ALSO UNCONSTRAINED, AND A DISCRIMINANT VALUE FOR X LIES OUTSIDE +-- THE RANGE OF THE CORRESPONDING DISCRIMINANT SPECIFICATION FOR THE +-- DESIGNATED TYPE, OR A NON-NULL INDEX BOUND LIES OUTSIDE THE RANGE OF +-- AN INDEX SUBTYPE OF THE DESIGNATED TYPE. + +-- EG 08/30/84 + +WITH REPORT; + +PROCEDURE C48009J IS + + USE REPORT; + +BEGIN + + TEST("C48009J","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - ACCESS TYPE OF UNCONSTRAINED " & + "ACCESS TYPE"); + + DECLARE + + TYPE INT IS RANGE 1 .. 5; + + TYPE UR(A : INT) IS + RECORD + NULL; + END RECORD; + TYPE UA IS ARRAY(INT RANGE <>) OF INTEGER; + + PACKAGE P IS + TYPE UP(A : INT) IS PRIVATE; + TYPE UL(A : INT) IS LIMITED PRIVATE; + PRIVATE + TYPE UP(A : INT) IS + RECORD + NULL; + END RECORD; + TYPE UL(A : INT) IS + RECORD + NULL; + END RECORD; + END P; + + TYPE A_UR IS ACCESS UR; + TYPE A_UA IS ACCESS UA; + TYPE A_UP IS ACCESS P.UP; + TYPE A_UL IS ACCESS P.UL; + + TYPE AA_UR IS ACCESS A_UR; + TYPE AA_UA IS ACCESS A_UA; + TYPE AA_UP IS ACCESS A_UP; + TYPE AA_UL IS ACCESS A_UL; + + V_AA_UR : AA_UR; + V_AA_UA : AA_UA; + V_AA_UP : AA_UP; + V_AA_UL : AA_UL; + + BEGIN + + BEGIN + V_AA_UR := NEW A_UR'(NEW UR(INT(IDENT_INT(6)))); + FAILED ("NO EXCEPTION RAISED - UR"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UR"); + END; + + BEGIN + V_AA_UA := NEW A_UA'(NEW UA(4 .. 7)); + FAILED ("NO EXCEPTION RAISED - UA"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UA"); + END; + + BEGIN + V_AA_UP := NEW A_UP'(NEW P.UP(0)); + FAILED ("NO EXCEPTION RAISED - UP"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UP"); + END; + + BEGIN + V_AA_UL := NEW A_UL'(NEW P.UL(INT(IDENT_INT(0)))); + FAILED ("NO EXCEPTION RAISED - UL"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UL"); + END; + + END; + + RESULT; + +END C48009J; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48010a.ada b/gcc/testsuite/ada/acats/tests/c4/c48010a.ada new file mode 100644 index 000000000..15c7e2172 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48010a.ada @@ -0,0 +1,90 @@ +-- C48010A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT NULL ARRAYS AND NULL RECORDS CAN BE ALLOCATED. + +-- EG 08/30/84 + +WITH REPORT; + +PROCEDURE C48010A IS + + USE REPORT; + +BEGIN + + TEST("C48010A","CHECK THAT NULL ARRAYS AND NULL RECORDS CAN " & + "BE ALLOCATED"); + + DECLARE + + TYPE CA IS ARRAY(4 .. 3) OF INTEGER; + TYPE CR IS + RECORD + NULL; + END RECORD; + + TYPE A_CA IS ACCESS CA; + TYPE A_CR IS ACCESS CR; + + TYPE AA_CA IS ACCESS A_CA; + TYPE AA_CR IS ACCESS A_CR; + + V_A_CA : A_CA; + V_A_CR : A_CR; + V_AA_CA : AA_CA; + V_AA_CR : AA_CR; + + BEGIN + + V_A_CA := NEW CA; + IF V_A_CA = NULL THEN + FAILED ("NULL ARRAY WAS NOT ALLOCATED - CA"); + ELSIF V_A_CA.ALL'FIRST /= 4 AND V_A_CA.ALL'LAST /= 3 THEN + FAILED ("NULL ARRAY BOUNDS ARE INCORRECT - CA"); + END IF; + + V_A_CR := NEW CR; + IF V_A_CR = NULL THEN + FAILED ("NULL RECORD WAS NOT ALLOCATED - CR"); + END IF; + + V_AA_CA := NEW A_CA'(NEW CA); + IF V_AA_CA.ALL = NULL THEN + FAILED ("NULL ARRAY WAS NOT ALLOCATED - A_CA"); + ELSIF V_AA_CA.ALL.ALL'FIRST /= 4 AND + V_AA_CA.ALL.ALL'LAST /= 3 THEN + FAILED ("NULL ARRAY BOUNDS ARE INCORRECT - A_CA"); + END IF; + + V_AA_CR := NEW A_CR'(NEW CR); + IF (V_AA_CR = NULL OR V_AA_CR.ALL = NULL) THEN + FAILED ("NULL RECORD WAS NOT ALLOCATED - A_CR"); + END IF; + + END; + + RESULT; + +END C48010A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48011a.ada b/gcc/testsuite/ada/acats/tests/c4/c48011a.ada new file mode 100644 index 000000000..7281fce9a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48011a.ada @@ -0,0 +1,101 @@ +-- C48011A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT OVERLOADED ALLOCATORS ARE DETERMINED TO HAVE THE +-- APPROPRIATE TYPE. + +-- HISTORY: +-- JET 08/17/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C48011A IS + + TYPE ACC1 IS ACCESS INTEGER; + TYPE ACC2 IS ACCESS INTEGER; + + A1 : ACC1 := NULL; + A2 : ACC2 := NULL; + + TYPE REC1 IS RECORD + A : INTEGER; + END RECORD; + + TYPE REC2 IS RECORD + A : ACC2; + END RECORD; + + TYPE AREC1 IS ACCESS REC1; + TYPE AREC2 IS ACCESS REC2; + + PROCEDURE PROC(A : ACC1) IS + BEGIN + IF A.ALL /= 1 THEN + FAILED("INCORRECT CALL OF FIRST PROC"); + END IF; + END PROC; + + PROCEDURE PROC(A : INTEGER) IS + BEGIN + IF A /= 2 THEN + FAILED("INCORRECT CALL OF SECOND PROC"); + END IF; + END PROC; + + FUNCTION FUNC(I : INTEGER) RETURN AREC1 IS + BEGIN + IF I /= 1 THEN + FAILED("INCORRECT CALL OF FIRST FUNC"); + END IF; + RETURN NEW REC1'(A => 0); + END FUNC; + + FUNCTION FUNC(I : INTEGER) RETURN AREC2 IS + BEGIN + IF I /= 2 THEN + FAILED("INCORRECT CALL OF SECOND FUNC"); + END IF; + RETURN NEW REC2'(A => NULL); + END FUNC; + +BEGIN + TEST ("C48011A", "CHECK THAT OVERLOADED ALLOCATORS ARE " & + "DETERMINED TO HAVE THE APPROPRIATE TYPE"); + + IF A1 = NEW INTEGER'(1) THEN + FAILED("INCORRECT RETURN VALUE FROM ALLOCATOR 1"); + END IF; + + IF A2 = NEW INTEGER'(2) THEN + FAILED("INCORRECT RETURN VALUE FROM ALLOCATOR 2"); + END IF; + + FUNC(1).A := INTEGER'(1); + FUNC(IDENT_INT(2)).A := NEW INTEGER'(2); + + PROC(NEW INTEGER'(IDENT_INT(1))); + PROC(IDENT_INT(2)); + + RESULT; +END C48011A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c48012a.ada b/gcc/testsuite/ada/acats/tests/c4/c48012a.ada new file mode 100644 index 000000000..f85ad782f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48012a.ada @@ -0,0 +1,75 @@ +-- C48012A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT DISCRIMINANTS GOVERNING VARIANT PARTS NEED NOT BE +-- SPECIFIED WITH STATIC VALUES IN AN ALLOCATOR OF THE FORM +-- "NEW T X". + +-- EG 08/30/84 + +WITH REPORT; + +PROCEDURE C48012A IS + + USE REPORT; + +BEGIN + + TEST("C48012A","CHECK THAT DISCRIMINANTS GOVERNING VARIANT " & + "PARTS NEED NOT BE SPECIFIED WITH STATIC " & + "VALUES IN AN ALLOCATOR OF THE FORM 'NEW T X'"); + + DECLARE + + TYPE INT IS RANGE 1 .. 5; + TYPE ARR IS ARRAY(INT RANGE <>) OF INTEGER; + + TYPE UR(A : INT) IS + RECORD + CASE A IS + WHEN 1 => + NULL; + WHEN OTHERS => + B : ARR(1 .. A); + END CASE; + END RECORD; + + TYPE A_UR IS ACCESS UR; + + V_A_UR : A_UR; + + BEGIN + + V_A_UR := NEW UR(A => INT(IDENT_INT(2))); + IF V_A_UR.A /= 2 THEN + FAILED ("WRONG DISCRIMINANT VALUE"); + ELSIF V_A_UR.B'FIRST /= 1 AND V_A_UR.B'LAST /= 2 THEN + FAILED ("WRONG BOUNDS IN VARIANT PART"); + END IF; + + END; + + RESULT; + +END C48012A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c490001.a b/gcc/testsuite/ada/acats/tests/c4/c490001.a new file mode 100644 index 000000000..19153504c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c490001.a @@ -0,0 +1,215 @@ +-- C490001.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 real static expression that is not part of a larger +-- static expression, and whose expected type T is a floating point type +-- that is not a descendant of a formal scalar type, the value is rounded +-- to the nearest machine number of T if T'Machine_Rounds is true, and is +-- truncated otherwise. Check that if rounding is performed, and the value +-- is exactly halfway between two machine numbers, one of the two machine +-- numbers is used. +-- +-- TEST DESCRIPTION: +-- The test obtains a machine number M1 for a floating point subtype S by +-- passing a real literal to S'Machine. It then obtains an adjacent +-- machine number M2 by using S'Succ (or S'Pred). It then constructs +-- values which lie between these two machine numbers: one (A) which is +-- closer to M1, one (B) which is exactly halfway between M1 and M2, and +-- one (C) which is closer to M2. This is done for both positive and +-- negative machine numbers. +-- +-- Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true, +-- C must be rounded to M2, A must be rounded to M1, and B must be rounded +-- to either M1 or M2. If S'Machine_Rounds is false, all the values must +-- be truncated to M1. +-- +-- A, B, and C are constructed using the following static expressions: +-- +-- A: constant S := M1 + (M2 - M1)*Z; -- Z slightly less than 0.5. +-- B: constant S := M1 + (M2 - M1)*Z; -- Z equals 0.5. +-- C: constant S := M1 + (M2 - M1)*Z; -- Z slightly more than 0.5. +-- +-- Since these are static expressions, they must be evaluated exactly, +-- and no rounding may occur until the final result is calculated. +-- +-- The checks for equality between the members of (A, B, C) and (M1, M2) +-- are performed at run-time within the body of a subprogram. +-- +-- The test performs additional checks that the rounding performed on +-- real literals is consistent for a floating point subtype. A literal is +-- assigned to a constant of a floating point subtype S. The same literal +-- is then passed to a subprogram, along with the constant, and an +-- equality check is performed within the body of the subprogram. +-- +-- +-- CHANGE HISTORY: +-- 25 Sep 95 SAIC Initial prerelease version. +-- 25 May 01 RLB Repaired to work with the repeal of the round away +-- rule by AI-268. +-- +--! + +with System; +package C490001_0 is + + type My_Flt is digits System.Max_Digits; + + procedure Float_Subtest (A, B: in My_Flt; Msg: in String); + + procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String); + + +-- +-- Positive cases: +-- + + -- |----|-------------|-----------------|-------------------|-----------| + -- | | | | | | + -- 0 P_M1 Less_Pos_Than_Half Pos_Exactly_Half More_Pos_Than_Half P_M2 + + + Positive_Float : constant My_Flt := 12.440193950021943; + + -- The literal value 12.440193950021943 is rounded up or down to the + -- nearest machine number of My_Flt when Positive_Float is initialized. + -- The value of Positive_Float should therefore be a machine number, and + -- the use of 'Machine in the initialization of P_M1 will be redundant for + -- a correct implementation. It's done anyway to make certain that P_M1 is + -- a machine number, independent of whether an implementation correctly + -- performs rounding. + + P_M1 : constant My_Flt := My_Flt'Machine(Positive_Float); + P_M2 : constant My_Flt := My_Flt'Succ(P_M1); + + -- P_M1 and P_M2 are adjacent machine numbers. Note that because it is not + -- certain whether 12.440193950021943 is a machine number, nor whether + -- 'Machine rounds it up or down, 12.440193950021943 may not lie between + -- P_M1 and P_M2. The test does not depend on this information, however; + -- the literal is only used as a "seed" to obtain the machine numbers. + + + -- The following entities are used to verify that rounding is performed + -- according to the value of 'Machine_Rounds. If language rules are + -- obeyed, the intermediate expressions in the following static + -- initialization expressions will not be rounded; all calculations will + -- be performed exactly. The final result, however, will be rounded to + -- a machine number (either P_M1 or P_M2, depending on the value of + -- My_Flt'Machine_Rounds). Thus, the value of each constant below will + -- equal that of P_M1 or P_M2. + + Less_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*2.9/6.0); + Pos_Exactly_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)/2.0); + More_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*4.6/9.0); + + +-- +-- Negative cases: +-- + + -- -|-------------|-----------------|-------------------|-----------|----| + -- | | | | | | + -- N_M2 More_Neg_Than_Half Neg_Exactly_Half Less_Neg_Than_Half N_M1 0 + + + -- The descriptions for the positive cases above apply to the negative + -- cases below as well. Note that, for N_M2, 'Pred is used rather than + -- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1. + + Negative_Float : constant My_Flt := -0.692074550952117; + + + N_M1 : constant My_Flt := My_Flt'Machine(Negative_Float); + N_M2 : constant My_Flt := My_Flt'Pred(N_M1); + + More_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*4.1/8.0); + Neg_Exactly_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)/2.0); + Less_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*2.4/5.0); + +end C490001_0; + + + --==================================================================-- + + +with TCTouch; +package body C490001_0 is + + procedure Float_Subtest (A, B: in My_Flt; Msg: in String) is + begin + TCTouch.Assert (A = B, Msg); + end Float_Subtest; + + procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String) is + begin + TCTouch.Assert (A = B or A = C, Msg); + end Float_Subtest; + +end C490001_0; + + + --==================================================================-- + + +with C490001_0; -- Floating point support. +use C490001_0; + +with Report; +procedure C490001 is +begin + Report.Test ("C490001", "Rounding of real static expressions: " & + "floating point subtypes"); + + + -- Check that rounding direction is consistent for literals: + + Float_Subtest (12.440193950021943, P_M1, "Positive Float: literal"); + Float_Subtest (-0.692074550952117, N_M1, "Negative Float: literal"); + + + -- Now check that rounding is performed correctly for values between + -- machine numbers, according to the value of 'Machine_Rounds: + + if My_Flt'Machine_Rounds then + Float_Subtest (Pos_Exactly_Half, P_M1, P_M2, "Positive Float: = half"); + Float_Subtest (More_Pos_Than_Half, P_M2, "Positive Float: > half"); + Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half"); + + Float_Subtest (Neg_Exactly_Half, N_M1, N_M2, "Negative Float: = half"); + Float_Subtest (More_Neg_Than_Half, N_M2, "Negative Float: > half"); + Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half"); + else + Float_Subtest (Pos_Exactly_Half, P_M1, "Positive Float: = half"); + Float_Subtest (More_Pos_Than_Half, P_M1, "Positive Float: > half"); + Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half"); + + Float_Subtest (Neg_Exactly_Half, N_M1, "Negative Float: = half"); + Float_Subtest (More_Neg_Than_Half, N_M1, "Negative Float: > half"); + Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half"); + end if; + + + Report.Result; +end C490001; diff --git a/gcc/testsuite/ada/acats/tests/c4/c490002.a b/gcc/testsuite/ada/acats/tests/c4/c490002.a new file mode 100644 index 000000000..71169b833 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c490002.a @@ -0,0 +1,239 @@ +-- C490002.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 real static expression that is not part of a larger +-- static expression, and whose expected type T is an ordinary fixed +-- point type that is not a descendant of a formal scalar type, the value +-- is rounded to the nearest integral multiple of the small of T if +-- T'Machine_Rounds is true, and is truncated otherwise. Check that if +-- rounding is performed, and the value is exactly halfway between two +-- multiples of the small, one of the two multiples of small is used. +-- +-- TEST DESCRIPTION: +-- The test obtains an integral multiple M1 of the small of an ordinary +-- fixed point subtype S by dividing a real literal by S'Small, and then +-- truncating the result using 'Truncation. It then obtains an adjacent +-- multiple M2 of the small by using S'Succ (or S'Pred). It then +-- constructs values which lie between these multiples: one (A) which is +-- closer to M1, one (B) which is exactly halfway between M1 and M2, and +-- one (C) which is closer to M2. This is done for both positive and +-- negative multiples of the small. +-- +-- Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true, +-- C must be rounded to M2, A must be rounded to M1, and B must be rounded +-- to either M1 or M2. If S'Machine_Rounds is false, all the values must +-- be truncated to M1. +-- +-- A, B, and C are constructed using the following static expressions: +-- +-- A: constant S := M1 + (M2 - M1)/Z; -- Z slightly more than 2.0. +-- B: constant S := M1 + (M2 - M1)/Z; -- Z equals 2.0. +-- C: constant S := M1 + (M2 - M1)/Z; -- Z slightly less than 2.0. +-- +-- Since these are static expressions, they must be evaluated exactly, +-- and no rounding may occur until the final result is calculated. +-- +-- The checks for equality between the members of (A, B, C) and (M1, M2) +-- are performed at run-time within the body of a subprogram. +-- +-- The test performs additional checks that the rounding performed on +-- real literals is consistent for ordinary fixed point subtypes. A +-- named number (initialized with a literal) is assigned to a constant of +-- a fixed point subtype S. The same literal is then passed to a +-- subprogram, along with the constant, and an equality check is +-- performed within the body of the subprogram. +-- +-- +-- CHANGE HISTORY: +-- 26 Sep 95 SAIC Initial prerelease version. +-- +--! + +package C490002_0 is + + type My_Fix is delta 0.0625 range -1000.0 .. 1000.0; + + Small : constant := My_Fix'Small; -- Named number. + + procedure Fixed_Subtest (A, B: in My_Fix; Msg: in String); + + procedure Fixed_Subtest (A, B, C: in My_Fix; Msg: in String); + + +-- +-- Positive cases: +-- + + -- |----|-------------|-----------------|-------------------|-----------| + -- | | | | | | + -- 0 P_M1 Less_Pos_Than_Half Pos_Exactly_Half More_Pos_Than_Half P_M2 + + + Positive_Real : constant := 0.11433; -- Named number. + Pos_Multiplier : constant := Float'Truncation(Positive_Real/Small); + + -- Pos_Multiplier is the number of integral multiples of small contained + -- in Positive_Real. P_M1 is thus the largest integral multiple of + -- small less than or equal to Positive_Real. Note that since Positive_Real + -- is a named number and not a fixed point object, P_M1 is generated + -- without assuming that rounding is performed correctly for fixed point + -- subtypes. + + Positive_Fixed : constant My_Fix := Positive_Real; + + P_M1 : constant My_Fix := Pos_Multiplier * Small; + P_M2 : constant My_Fix := My_Fix'Succ(P_M1); + + -- P_M1 and P_M2 are adjacent multiples of the small of My_Fix. Note that + -- 0.11433 either equals P_M1 (if it is an integral multiple of the small) + -- or lies between P_M1 and P_M2 (since truncation was forced in + -- generating Pos_Multiplier). It is not certain, however, exactly where + -- it lies between them (halfway, less than halfway, more than halfway). + -- This fact is irrelevant to the test. + + + -- The following entities are used to verify that rounding is performed + -- according to the value of 'Machine_Rounds. If language rules are + -- obeyed, the intermediate expressions in the following static + -- initialization expressions will not be rounded; all calculations will + -- be performed exactly. The final result, however, will be rounded to + -- an integral multiple of the small (either P_M1 or P_M2, depending on the + -- value of My_Fix'Machine_Rounds). Thus, the value of each constant below + -- will equal that of P_M1 or P_M2. + + Less_Pos_Than_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/2.050); + Pos_Exactly_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/2.000); + More_Pos_Than_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/1.975); + + +-- +-- Negative cases: +-- + + -- -|-------------|-----------------|-------------------|-----------|----| + -- | | | | | | + -- N_M2 More_Neg_Than_Half Neg_Exactly_Half Less_Neg_Than_Half N_M1 0 + + + -- The descriptions for the positive cases above apply to the negative + -- cases below as well. Note that, for N_M2, 'Pred is used rather than + -- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1. + + Negative_Real : constant := -467.13988; -- Named number. + Neg_Multiplier : constant := Float'Truncation(Negative_Real/Small); + + Negative_Fixed : constant My_Fix := Negative_Real; + + N_M1 : constant My_Fix := Neg_Multiplier * Small; + N_M2 : constant My_Fix := My_Fix'Pred(N_M1); + + More_Neg_Than_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/1.980); + Neg_Exactly_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/2.000); + Less_Neg_Than_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/2.033); + +end C490002_0; + + + --==================================================================-- + + +with TCTouch; +package body C490002_0 is + + procedure Fixed_Subtest (A, B: in My_Fix; Msg: in String) is + begin + TCTouch.Assert (A = B, Msg); + end Fixed_Subtest; + + procedure Fixed_Subtest (A, B, C: in My_Fix; Msg: in String) is + begin + TCTouch.Assert (A = B or A = C, Msg); + end Fixed_Subtest; + +end C490002_0; + + + --==================================================================-- + + +with C490002_0; -- Fixed point support. +use C490002_0; + +with Report; +procedure C490002 is +begin + Report.Test ("C490002", "Rounding of real static expressions: " & + "ordinary fixed point subtypes"); + + + -- Literal cases: If the named numbers used to initialize Positive_Fixed + -- and Negative_Fixed are rounded to an integral multiple of the small + -- prior to assignment (as expected), then Positive_Fixed and + -- Negative_Fixed are already integral multiples of the small, and + -- equal either P_M1 or P_M2 (resp., N_M1 or N_M2). An equality check + -- can determine in which direction rounding occurred. For example: + -- + -- if (Positive_Fixed = P_M1) then -- Rounding was toward 0.0. + -- + -- Check here that the rounding direction is consistent for literals: + + if (Positive_Fixed = P_M1) then + Fixed_Subtest (0.11433, P_M1, "Positive Fixed: literal"); + else + Fixed_Subtest (0.11433, P_M2, "Positive Fixed: literal"); + end if; + + if (Negative_Fixed = N_M1) then + Fixed_Subtest (-467.13988, N_M1, "Negative Fixed: literal"); + else + Fixed_Subtest (-467.13988, N_M2, "Negative Fixed: literal"); + end if; + + + -- Now check that rounding is performed correctly for values between + -- multiples of the small, according to the value of 'Machine_Rounds: + + if My_Fix'Machine_Rounds then + Fixed_Subtest (Pos_Exactly_Half, P_M1, P_M2, "Positive Fixed: = half"); + Fixed_Subtest (More_Pos_Than_Half, P_M2, "Positive Fixed: > half"); + Fixed_Subtest (Less_Pos_Than_Half, P_M1, "Positive Fixed: < half"); + + Fixed_Subtest (Neg_Exactly_Half, N_M1, N_M2, "Negative Fixed: = half"); + Fixed_Subtest (More_Neg_Than_Half, N_M2, "Negative Fixed: > half"); + Fixed_Subtest (Less_Neg_Than_Half, N_M1, "Negative Fixed: < half"); + else + Fixed_Subtest (Pos_Exactly_Half, P_M1, "Positive Fixed: = half"); + Fixed_Subtest (More_Pos_Than_Half, P_M1, "Positive Fixed: > half"); + Fixed_Subtest (Less_Pos_Than_Half, P_M1, "Positive Fixed: < half"); + + Fixed_Subtest (Neg_Exactly_Half, N_M1, "Negative Fixed: = half"); + Fixed_Subtest (More_Neg_Than_Half, N_M1, "Negative Fixed: > half"); + Fixed_Subtest (Less_Neg_Than_Half, N_M1, "Negative Fixed: < half"); + end if; + + + Report.Result; +end C490002; diff --git a/gcc/testsuite/ada/acats/tests/c4/c490003.a b/gcc/testsuite/ada/acats/tests/c4/c490003.a new file mode 100644 index 000000000..a135b5ac3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c490003.a @@ -0,0 +1,215 @@ +-- C490003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a static expression is legal if its evaluation fails +-- no language-defined check other than Overflow_Check. Check that such +-- a static expression is legal if it is part of a larger static +-- expression, even if its value is outside the base range of the +-- expected type. +-- +-- Check that if a static expression is part of the right operand of a +-- short circuit control form whose value is determined by its left +-- operand, it is not evaluated. +-- +-- Check that a static expression in a non-static context is evaluated +-- exactly. +-- +-- TEST DESCRIPTION: +-- The first part of the objective is tested by constructing static +-- expressions which involve predefined operations of integer, floating +-- point, and fixed point subtypes. Intermediate expressions within the +-- static expressions have values outside the base range of the expected +-- type. In one case, the extended-range intermediates are compared as +-- part of a boolean expression. In the remaining two cases, further +-- predefined operations on the intermediates bring the final result +-- within the base range. An implementation which compiles these static +-- expressions satisfies this portion of the objective. A check is +-- performed at run-time to ensure that the static expressions evaluate +-- to values within the base range of their respective expected types. +-- +-- The second part of the objective is tested by constructing +-- short-circuit control forms whose left operands have the values +-- shown below: +-- +-- (TRUE) or else (...) +-- (FALSE) and then (...) +-- +-- In both cases the left operand determines the value of the condition. +-- In the test each right operand involves a division by zero, which will +-- raise Constraint_Error if evaluated. A check is made that no exception +-- is raised when each short-circuit control form is evaluated, and that +-- the value of the condition is that of the left operand. +-- +-- The third part of the objective is tested by evaluating static +-- expressions involving many operations in contexts which do not +-- require a static expression, and verifying that the exact +-- mathematical results are calculated. +-- +-- +-- CHANGE HISTORY: +-- 15 Sep 95 SAIC Initial prerelease version for ACVC 2.1. +-- 20 Oct 96 SAIC Modified expressions in C490003_0 to avoid +-- the use of universal operands. +-- +--! + +with System; +package C490003_0 is + + type My_Flt is digits System.Max_Digits; + + Flt_Range_Diff : My_Flt := (My_Flt'Base'Last - My_Flt'Base'First) - + (My_Flt'Last - My_Flt'First); -- OK. + + + type My_Fix is delta 0.125 range -128.0 .. 128.0; + + Symmetric : Boolean := (My_Fix'Base'Last - My_Fix'Base'First) = + (My_Fix'Base'Last + My_Fix'Base'Last); -- OK. + + + Center : constant Integer := Integer'Base'Last - + (Integer'Base'Last - + Integer'Base'First) / 2; -- OK. + +end C490003_0; + + + --==================================================================-- + + +with Ada.Numerics; +package C490003_1 is + + Zero : constant := 0.0; + Pi : constant := Ada.Numerics.Pi; + + Two_Pi : constant := 2.0 * Pi; + Half_Pi : constant := Pi/2.0; + + Quarter : constant := 90.0; + Half : constant := 180.0; + Full : constant := 360.0; + + Deg_To_Rad : constant := Half_Pi/90; + Rad_To_Deg : constant := 1.0/Deg_To_Rad; + +end C490003_1; + + + --==================================================================-- + + +with C490003_0; +with C490003_1; + +with Report; +procedure C490003 is +begin + Report.Test ("C490003", "Check that static expressions failing " & + "Overflow_Check are legal if part of a larger static " & + "expression. Check that static expressions as right " & + "operands of short-circuit control forms are not " & + "evaluated if value of control form is determined by " & + "left operand. Check that static expressions in non-static " & + "contexts are evaluated exactly"); + + +-- +-- Static expressions within larger static expressions: +-- + + + if C490003_0.Flt_Range_Diff not in C490003_0.My_Flt'Base'Range then + Report.Failed ("Error evaluating static expression: floating point"); + end if; + + if C490003_0.Symmetric not in Boolean'Range then + Report.Failed ("Error evaluating static expression: fixed point"); + end if; + + if C490003_0.Center not in Integer'Base'Range then + Report.Failed ("Error evaluating static expression: integer"); + end if; + + +-- +-- Short-circuit control forms: +-- + + declare + N : constant := 0.0; + begin + + begin + if not ( (N = 0.0) or else (1.0/N > 0.5) ) then + Report.Failed ("Error evaluating OR ELSE"); + end if; + exception + when Constraint_Error => + Report.Failed ("Right side of OR ELSE was evaluated"); + when others => + Report.Failed ("OR ELSE: unexpected exception raised"); + end; + + begin + if (N /= 0.0) and then (1.0/N <= 0.5) then + Report.Failed ("Error evaluating AND THEN"); + end if; + exception + when Constraint_Error => + Report.Failed ("Right side of AND THEN was evaluated"); + when others => + Report.Failed ("AND THEN: unexpected exception raised"); + end; + + end; + + +-- +-- Exact evaluation of static expressions: +-- + + + declare + use C490003_1; + + Left : constant := 6.0 + 0.3125*( (Full*0.375) + (Half/2.4) - + ((Quarter + 36.0)/3.0) )/10.0; -- 11.25 + Right : constant := (Pi/3.0) * 1.2 * (15.0/96.0); -- Pi/16 + begin + if Deg_To_Rad*Left /= Right then + Report.Failed ("Static expressions not evaluated exactly: #1"); + end if; + + if ((Pi*Rad_To_Deg)*2.0 + 4.0*Quarter)/16.0 /= Rad_To_Deg*(Pi/4.0) then + Report.Failed ("Static expressions not evaluated exactly: #2"); + end if; + end; + + + Report.Result; +end C490003; diff --git a/gcc/testsuite/ada/acats/tests/c4/c49020a.ada b/gcc/testsuite/ada/acats/tests/c4/c49020a.ada new file mode 100644 index 000000000..ebd2fde9a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49020a.ada @@ -0,0 +1,73 @@ +-- C49020A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ENUMERATION LITERALS (INCLUDING CHARACTER LITERALS) CAN BE +-- USED IN STATIC EXPRESSIONS TOGETHER WITH RELATIONAL AND EQUALITY +-- OPERATORS. + +-- L.BROWN 09/30/86 + +WITH REPORT; USE REPORT; +PROCEDURE C49020A IS + + CAS_BOL : BOOLEAN := TRUE; + OBJ1 : INTEGER := 4; + TYPE ENUM IS (RED,GREEN,BLUE,OFF,ON,'A','B'); + +BEGIN + TEST("C49020A","ENUMERATION LITERALS (INCLUDING CHARACTER "& + "LITERALS) TOGETHER WITH RELATIONAL OPERATORS "& + "CAN BE USED IN STATIC EXPRESSION"); + + CASE CAS_BOL IS + WHEN (RED <= BLUE) => + OBJ1 := 5; + WHEN (BLUE = GREEN) => + FAILED("INCORRECT VALUE RETURNED BY ENUMERATION "& + "EXPRESSION 1"); + END CASE; + + CAS_BOL := TRUE; + + CASE CAS_BOL IS + WHEN (GREEN >= ON) => + FAILED("INCORRECT VALUE RETURNED BY ENUMERATION "& + "EXPRESSION 2"); + WHEN (ENUM'('A') < ENUM'('B')) => + OBJ1 := 6; + END CASE; + + CAS_BOL := TRUE; + + CASE CAS_BOL IS + WHEN (BLUE > 'B') => + FAILED("INCORRECT VALUE RETURNED BY ENUMERATION "& + "EXPRESSION 3"); + WHEN (OFF /= 'A') => + OBJ1 := 7; + END CASE; + + RESULT; + +END C49020A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c49021a.ada b/gcc/testsuite/ada/acats/tests/c4/c49021a.ada new file mode 100644 index 000000000..b58fcd468 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49021a.ada @@ -0,0 +1,83 @@ +-- C49021A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT BOOLEAN LITERALS CAN BE USED IN STATIC EXPRESSIONS +-- TOGETHER WITH THE LOGICAL OPERATORS, THE NOT OPERATOR, AND THE +-- RELATIONAL AND EQUALITY OPERATORS. + +-- L.BROWN 09/25/86 + +WITH REPORT; USE REPORT; +PROCEDURE C49021A IS + + CAS_BOL : BOOLEAN := TRUE; + X1 : CONSTANT := BOOLEAN'POS((TRUE AND FALSE)OR(TRUE AND TRUE)); + X2 : CONSTANT := BOOLEAN'POS((TRUE <= FALSE)AND(FALSE >= FALSE)); + +BEGIN + TEST("C49021A","BOOLEAN LITERALS TOGETHER WITH CERTAIN OPERATORS,"& + "CAN BE USED IN STATIC EXPRESSIONS."); + IF X1 /= 1 THEN + FAILED("INCORRECT VALUE RETURNED BY BOOLEAN EXPRESSION 1"); + END IF; + + IF X2 /= 0 THEN + FAILED("INCORRECT VALUE RETURNED BY BOOLEAN EXPRESSION 2"); + END IF; + + CASE CAS_BOL IS + WHEN ((TRUE AND FALSE) XOR (TRUE XOR TRUE)) => + FAILED("INCORRECT VALUE RETURNED BY BOOLEAN " & + "EXPRESSION 2"); + WHEN OTHERS => + CAS_BOL := TRUE; + END CASE; + + CASE CAS_BOL IS + WHEN ((TRUE > FALSE) OR (FALSE <= TRUE)) => + CAS_BOL := TRUE; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED BY BOOLEAN " & + "EXPRESSION 3"); + END CASE; + + CASE CAS_BOL IS + WHEN NOT((TRUE OR FALSE) = (FALSE AND TRUE)) => + CAS_BOL := TRUE; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED BY BOOLEAN " & + "EXPRESSION 4"); + END CASE; + + CASE CAS_BOL IS + WHEN (((TRUE = FALSE) OR (FALSE AND TRUE)) /= (TRUE < TRUE))=> + FAILED("INCORRECT VALUE RETURNED BY BOOLEAN " & + "EXPRESSION 5"); + WHEN OTHERS => + CAS_BOL := TRUE; + END CASE; + + RESULT; + +END C49021A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c49022a.ada b/gcc/testsuite/ada/acats/tests/c4/c49022a.ada new file mode 100644 index 000000000..d0cfa9d97 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49022a.ada @@ -0,0 +1,158 @@ +-- C49022A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT NAMED NUMBER DECLARATIONS (INTEGER) MAY USE EXPRESSIONS +-- WITH INTEGERS. + +-- BAW 29 SEPT 80 +-- TBN 10/28/85 RENAMED FROM C4A001A.ADA. ADDED RELATIONAL +-- OPERATORS AND USE OF NAMED NUMBERS. + +WITH REPORT; +PROCEDURE C49022A IS + + USE REPORT; + + ADD1 : CONSTANT := 1 + 1; + ADD2 : CONSTANT := 1 + (-1); + ADD3 : CONSTANT := (-1) + 1; + ADD4 : CONSTANT := (-1) + (-1); + SUB1 : CONSTANT := 1 - 1; + SUB2 : CONSTANT := 1 - (-1); + SUB3 : CONSTANT := (-1) - 1; + SUB4 : CONSTANT := (-1) - (-1); + MUL1 : CONSTANT := 1 * 1; + MUL2 : CONSTANT := 1 * (-1); + MUL3 : CONSTANT := (-1) * 1; + MUL4 : CONSTANT := (-1) * (-1); + DIV1 : CONSTANT := 1 / 1; + DIV2 : CONSTANT := 1 / (-1); + DIV3 : CONSTANT := (-1) / 1; + DIV4 : CONSTANT := (-1) / (-1); + REM1 : CONSTANT := 14 REM 5; + REM2 : CONSTANT := 14 REM(-5); + REM3 : CONSTANT :=(-14) REM 5; + REM4 : CONSTANT :=(-14) REM(-5); + MOD1 : CONSTANT := 4 MOD 3; + MOD2 : CONSTANT := 4 MOD (-3); + MOD3 : CONSTANT := (-4) MOD 3; + MOD4 : CONSTANT := (-4) MOD (-3); + EXP1 : CONSTANT := 1 ** 1; + EXP2 : CONSTANT := (-1) ** 1; + ABS1 : CONSTANT := ABS( - 10 ); + ABS2 : CONSTANT := ABS( + 10 ); + TOT1 : CONSTANT := ADD1 + SUB1 - MUL1 + DIV1 - REM3 + MOD2 - EXP1; + LES1 : CONSTANT := BOOLEAN'POS (1 < 2); + LES2 : CONSTANT := BOOLEAN'POS (1 < (-2)); + LES3 : CONSTANT := BOOLEAN'POS ((-1) < (-2)); + LES4 : CONSTANT := BOOLEAN'POS (ADD1 < SUB1); + GRE1 : CONSTANT := BOOLEAN'POS (2 > 1); + GRE2 : CONSTANT := BOOLEAN'POS ((-1) > 2); + GRE3 : CONSTANT := BOOLEAN'POS ((-1) > (-2)); + GRE4 : CONSTANT := BOOLEAN'POS (ADD1 > SUB1); + LEQ1 : CONSTANT := BOOLEAN'POS (1 <= 1); + LEQ2 : CONSTANT := BOOLEAN'POS ((-1) <= 1); + LEQ3 : CONSTANT := BOOLEAN'POS ((-1) <= (-2)); + LEQ4 : CONSTANT := BOOLEAN'POS (ADD2 <= SUB3); + GEQ1 : CONSTANT := BOOLEAN'POS (2 >= 1); + GEQ2 : CONSTANT := BOOLEAN'POS ((-2) >= 1); + GEQ3 : CONSTANT := BOOLEAN'POS ((-2) >= (-1)); + GEQ4 : CONSTANT := BOOLEAN'POS (ADD2 >= SUB3); + EQU1 : CONSTANT := BOOLEAN'POS (2 = 2); + EQU2 : CONSTANT := BOOLEAN'POS ((-2) = 2); + EQU3 : CONSTANT := BOOLEAN'POS ((-2) = (-2)); + EQU4 : CONSTANT := BOOLEAN'POS (ADD2 = SUB3); + NEQ1 : CONSTANT := BOOLEAN'POS (2 /= 2); + NEQ2 : CONSTANT := BOOLEAN'POS ((-2) /= 1); + NEQ3 : CONSTANT := BOOLEAN'POS ((-2) /= (-2)); + NEQ4 : CONSTANT := BOOLEAN'POS (ADD2 /= SUB3); + + +BEGIN + TEST("C49022A","CHECK THAT NAMED NUMBER DECLARATIONS (INTEGER) " & + "MAY USE EXPRESSIONS WITH INTEGERS"); + + IF ADD1 /= 2 OR ADD2 /= 0 OR ADD3 /= 0 OR ADD4 /= -2 THEN + FAILED("ERROR IN THE ADDING OPERATOR +"); + END IF; + + IF SUB1 /= 0 OR SUB2 /= 2 OR SUB3 /= -2 OR SUB4 /= 0 THEN + FAILED("ERROR IN THE ADDING OPERATOR -"); + END IF; + + IF MUL1 /= 1 OR MUL2 /= -1 OR MUL3 /= -1 OR MUL4 /= 1 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR *"); + END IF; + + IF DIV1 /= 1 OR DIV2 /= -1 OR DIV3 /= -1 OR DIV4 /= 1 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR /"); + END IF; + + IF REM1 /= 4 OR REM2 /= 4 OR REM3 /= -4 OR REM4 /= -4 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR REM"); + END IF; + + IF MOD1 /= 1 OR MOD2 /= -2 OR MOD3 /= 2 OR MOD4 /= -1 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR MOD"); + END IF; + + IF EXP1 /= 1 OR EXP2 /= -1 THEN + FAILED("ERROR IN THE EXPONENTIATING OPERATOR"); + END IF; + + IF ABS1 /= 10 OR ABS2 /= 10 THEN + FAILED("ERROR IN THE ABS OPERATOR"); + END IF; + + IF TOT1 /= 3 THEN + FAILED("ERROR IN USING NAMED NUMBERS WITH OPERATORS"); + END IF; + + IF LES1 /= 1 OR LES2 /= 0 OR LES3 /= 0 OR LES4 /= 0 THEN + FAILED("ERROR IN THE LESS THAN OPERATOR"); + END IF; + + IF GRE1 /= 1 OR GRE2 /= 0 OR GRE3 /= 1 OR GRE4 /= 1 THEN + FAILED("ERROR IN THE GREATER THAN OPERATOR"); + END IF; + + IF LEQ1 /= 1 OR LEQ2 /= 1 OR LEQ3 /= 0 OR LEQ4 /= 0 THEN + FAILED("ERROR IN THE LESS THAN EQUAL OPERATOR"); + END IF; + + IF GEQ1 /= 1 OR GEQ2 /= 0 OR GEQ3 /= 0 OR GEQ4 /= 1 THEN + FAILED("ERROR IN THE GREATER THAN EQUAL OPERATOR"); + END IF; + + IF EQU1 /= 1 OR EQU2 /= 0 OR EQU3 /= 1 OR EQU4 /= 0 THEN + FAILED("ERROR IN THE EQUAL OPERATOR"); + END IF; + + IF NEQ1 /= 0 OR NEQ2 /= 1 OR NEQ3 /= 0 OR NEQ4 /= 1 THEN + FAILED("ERROR IN THE NOT EQUAL OPERATOR"); + END IF; + + RESULT; + +END C49022A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c49022b.ada b/gcc/testsuite/ada/acats/tests/c4/c49022b.ada new file mode 100644 index 000000000..a7fe57e3c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49022b.ada @@ -0,0 +1,73 @@ +-- C49022B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IN NUMBER DECLARATIONS, IDENTIFIERS CORRECTLY REPRESENT +-- VALUES OF OTHER LITERALS. + +-- BAW 29 SEPT 80 +-- TBN 10/22/85 RENAMED FROM C4A003A.ADA AND ADDED RELATIONAL +-- OPERATORS USING NAMED NUMBERS. + + +WITH REPORT; +PROCEDURE C49022B IS + + USE REPORT; + + A : CONSTANT := 10; -- A = 10 + B : CONSTANT := 25 - (2 * A); -- B = 5 + C : CONSTANT := A / B; -- C = 2 + D : CONSTANT := (C * A) - (B - C); -- D = 17 + E : CONSTANT := D ** C; -- E = 289 + F : CONSTANT := (E MOD A) + 1; -- F = 10 + G : CONSTANT := A REM B + C + D + E + ABS(-F); -- G = 318 + H : CONSTANT := BOOLEAN'POS (A > B); -- H = 1 + I : CONSTANT := BOOLEAN'POS (A < B); -- I = 0 + J : CONSTANT := BOOLEAN'POS (C >= A); -- J = 0 + K : CONSTANT := BOOLEAN'POS (B <= B); -- K = 1 + L : CONSTANT := BOOLEAN'POS (D = A); -- L = 0 + M : CONSTANT := BOOLEAN'POS (A /= F); -- M = 0 + +BEGIN + TEST("C49022B","CHECK THAT IN NUMBER DECLARATIONS, IDENTIFIERS " & + "CORRECTLY REPRESENT VALUES OF OTHER LITERALS"); + + IF G /= 318 THEN + FAILED("USE OF OTHER NUMBER DECLARATIONS GIVES " & + "WRONG RESULTS"); + END IF; + + IF H /= 1 OR I /= 0 OR J /= 0 OR K /= 1 THEN + FAILED("USE OF NAMED NUMBERS AND RELATIONAL OPERATORS " & + "GIVES WRONG RESULTS"); + END IF; + + IF L /= 0 OR M /= 0 THEN + FAILED("USE OF NAMED NUMBERS AND EQUALITY OPERATORS " & + "GIVES WRONG RESULTS"); + END IF; + + RESULT; + +END C49022B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c49022c.ada b/gcc/testsuite/ada/acats/tests/c4/c49022c.ada new file mode 100644 index 000000000..69822c83a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49022c.ada @@ -0,0 +1,170 @@ +-- C49022C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT NAMED NUMBER DECLARATIONS (REAL) MAY USE EXPRESSIONS +-- WITH REALS. + +-- BAW 29 SEPT 80 +-- TBN 10/24/85 RENAMED FROM C4A011A.ADA. ADDED RELATIONAL +-- OPERATORS AND NAMED NUMBERS. + +WITH REPORT; +PROCEDURE C49022C IS + + USE REPORT; + + ADD1 : CONSTANT := 2.5 + 1.5; + ADD2 : CONSTANT := 2.5 + (-1.5); + ADD3 : CONSTANT := (-2.5) + 1.5; + ADD4 : CONSTANT := (-2.5) + (-1.5); + SUB1 : CONSTANT := 2.5 - 1.5; + SUB2 : CONSTANT := 2.5 - (-1.5); + SUB3 : CONSTANT := (-2.5) - 1.5; + SUB4 : CONSTANT := (-2.5) - (-1.5); + MUL1 : CONSTANT := 2.5 * 1.5; + MUL2 : CONSTANT := 2.5 * (-1.5); + MUL3 : CONSTANT := (-2.5) * 1.5; + MUL4 : CONSTANT := (-2.5) * (-1.5); + MLR1 : CONSTANT := 2 * 1.5; + MLR2 : CONSTANT := (-2) * 1.5; + MLR3 : CONSTANT := 2 * (-1.5); + MLR4 : CONSTANT := (-2) * (-1.5); + MLL1 : CONSTANT := 1.5 * 2 ; + MLL2 : CONSTANT := 1.5 * (-2); + MLL3 : CONSTANT :=(-1.5) * 2 ; + MLL4 : CONSTANT :=(-1.5) * (-2); + DIV1 : CONSTANT := 3.75 / 2.5; + DIV2 : CONSTANT := 3.75 / (-2.5); + DIV3 : CONSTANT := (-3.75) / 2.5; + DIV4 : CONSTANT := (-3.75) / (-2.5); + DVI1 : CONSTANT := 3.0 / 2; + DVI2 : CONSTANT := (-3.0) / 2; + DVI3 : CONSTANT := 3.0 / (-2); + DVI4 : CONSTANT := (-3.0) / (-2); + EXP1 : CONSTANT := 2.0 ** 1; + EXP2 : CONSTANT := 2.0 ** (-1); + EXP3 : CONSTANT := (-2.0) ** 1; + EXP4 : CONSTANT := (-2.0) ** (-1); + ABS1 : CONSTANT := ABS( - 3.75 ); + ABS2 : CONSTANT := ABS( + 3.75 ); + TOT1 : CONSTANT := ADD1 + SUB4 - MUL1 + DIV1 - EXP2 + ABS1; + LES1 : CONSTANT := BOOLEAN'POS (1.5 < 2.0); + LES2 : CONSTANT := BOOLEAN'POS (1.5 < (-2.0)); + LES3 : CONSTANT := BOOLEAN'POS ((-1.5) < (-2.0)); + LES4 : CONSTANT := BOOLEAN'POS (ADD2 < SUB1); + GRE1 : CONSTANT := BOOLEAN'POS (2.0 > 1.5); + GRE2 : CONSTANT := BOOLEAN'POS ((-2.0) > 1.5); + GRE3 : CONSTANT := BOOLEAN'POS ((-2.0) > (-1.5)); + GRE4 : CONSTANT := BOOLEAN'POS (ADD1 > SUB1); + LEQ1 : CONSTANT := BOOLEAN'POS (1.5 <= 2.0); + LEQ2 : CONSTANT := BOOLEAN'POS (1.5 <= (-2.0)); + LEQ3 : CONSTANT := BOOLEAN'POS ((-1.5) <= (-2.0)); + LEQ4 : CONSTANT := BOOLEAN'POS (ADD2 <= SUB1); + GEQ1 : CONSTANT := BOOLEAN'POS (2.0 >= 1.5); + GEQ2 : CONSTANT := BOOLEAN'POS ((-2.0) >= 1.5); + GEQ3 : CONSTANT := BOOLEAN'POS ((-2.0) >= (-1.5)); + GEQ4 : CONSTANT := BOOLEAN'POS (ADD1 >= SUB2); + EQU1 : CONSTANT := BOOLEAN'POS (1.5 = 2.0); + EQU2 : CONSTANT := BOOLEAN'POS ((-1.5) = 2.0); + EQU3 : CONSTANT := BOOLEAN'POS ((-1.5) = (-1.5)); + EQU4 : CONSTANT := BOOLEAN'POS (ADD1 = SUB2); + NEQ1 : CONSTANT := BOOLEAN'POS (1.5 /= 1.5); + NEQ2 : CONSTANT := BOOLEAN'POS ((-1.5) /= 1.5); + NEQ3 : CONSTANT := BOOLEAN'POS ((-1.5) /= (-2.0)); + NEQ4 : CONSTANT := BOOLEAN'POS (ADD1 /= SUB2); + + +BEGIN + TEST("C49022C","CHECK THAT NAMED NUMBER DECLARATIONS (REAL) " & + "MAY USE EXPRESSIONS WITH REALS."); + + IF ADD1 /= 4.0 OR ADD2 /= 1.0 OR ADD3 /= -1.0 OR ADD4 /= -4.0 THEN + FAILED("ERROR IN THE ADDING OPERATOR +"); + END IF; + + IF SUB1 /= 1.0 OR SUB2 /= 4.0 OR SUB3 /= -4.0 OR SUB4 /= -1.0 THEN + FAILED("ERROR IN THE ADDING OPERATOR -"); + END IF; + + IF MUL1 /= 3.75 OR MUL2 /= -3.75 OR + MUL3 /= -3.75 OR MUL4 /= 3.75 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR *"); + END IF; + + IF MLR1 /= 3.0 OR MLR2 /= -3.0 OR + MLR3 /= -3.0 OR MLR4 /= 3.0 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR *"); + END IF; + + IF MLL1 /= 3.0 OR MLL2 /= -3.0 OR MLL3 /= -3.0 OR MLL4 /= 3.0 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR *"); + END IF; + + IF DIV1 /= 1.5 OR DIV2 /= -1.5 OR DIV3 /= -1.5 OR DIV4 /= 1.5 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR /"); + END IF; + + IF DVI1 /= 1.5 OR DVI2 /= -1.5 OR DVI3 /= -1.5 OR DVI4 /= 1.5 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR /"); + END IF; + + IF EXP1 /= 2.0 OR EXP2 /= 0.5 OR EXP3 /= -2.0 OR EXP4 /= -0.5 THEN + FAILED("ERROR IN THE EXPONENTIATING OPERATOR"); + END IF; + + IF ABS1 /= 3.75 OR ABS2 /= 3.75 THEN + FAILED("ERROR IN THE ABS OPERATOR"); + END IF; + + IF TOT1 /= 4.00 THEN + FAILED("ERROR IN USE OF NAMED NUMBERS WITH OPERATORS"); + END IF; + + IF LES1 /= 1 OR LES2 /= 0 OR LES3 /= 0 OR LES4 /= 0 THEN + FAILED("ERROR IN THE LESS THAN OPERATOR"); + END IF; + + IF GRE1 /= 1 OR GRE2 /= 0 OR GRE3 /= 0 OR GRE4 /= 1 THEN + FAILED("ERROR IN THE GREATER THAN OPERATOR"); + END IF; + + IF LEQ1 /= 1 OR LEQ2 /= 0 OR LEQ3 /= 0 OR LEQ4 /= 1 THEN + FAILED("ERROR IN THE LESS THAN EQUAL OPERATOR"); + END IF; + + IF GEQ1 /= 1 OR GEQ2 /= 0 OR GEQ3 /= 0 OR GEQ4 /= 1 THEN + FAILED("ERROR IN THE GREATER THAN EQUAL OPERATOR"); + END IF; + + IF EQU1 /= 0 OR EQU2 /= 0 OR EQU3 /= 1 OR EQU4 /= 1 THEN + FAILED("ERROR IN THE EQUAL OPERATOR"); + END IF; + + IF NEQ1 /= 0 OR NEQ2 /= 1 OR NEQ3 /= 1 OR NEQ4 /= 0 THEN + FAILED("ERROR IN THE NOT EQUAL OPERATOR"); + END IF; + + RESULT; + +END C49022C; diff --git a/gcc/testsuite/ada/acats/tests/c4/c49023a.ada b/gcc/testsuite/ada/acats/tests/c4/c49023a.ada new file mode 100644 index 000000000..052034270 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49023a.ada @@ -0,0 +1,117 @@ +-- C49023A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A CONSTANT DECLARED BY AN OBJECT DECLARATION CAN BE USED +-- IN A STATIC EXPRESSION IF THE CONSTANT WAS DECLARED WITH A STATIC +-- SUBTYPE AND INITIALIZED WITH A STATIC EXPRESSION. + +-- L.BROWN 10/01/86 + +WITH REPORT; USE REPORT; +PROCEDURE C49023A IS + +BEGIN + TEST("C49023A","A CONSTANT DECLARED BY AN OBJECT DECLARATION "& + "UNDER CERTAIN CONDITIONS CAN BE USED IN A "& + "STATIC EXPRESSION"); + DECLARE + TYPE ENUM IS (RED,GREEN,BLUE,YELLOW); + SUBTYPE SENUM IS ENUM RANGE RED .. BLUE; + CONEN : CONSTANT SENUM := GREEN; + TYPE INT IS RANGE 1 .. 10; + SUBTYPE SINT IS INT RANGE 1 .. 5; + CONIN : CONSTANT SINT := 3; + TYPE FLT IS DIGITS 3 RANGE 0.0 .. 25.0; + SUBTYPE SFLT IS FLT RANGE 10.0 .. 20.0; + CONFL : CONSTANT SFLT := 11.0; + TYPE FIX IS DELTA 0.25 RANGE 0.0 .. 25.0; + SUBTYPE SFIX IS FIX RANGE 0.0 .. 12.0; + CONFI : CONSTANT SFIX := 0.25; + CAS_EN : ENUM := CONEN; + TYPE ITEG IS RANGE 1 .. CONIN; + TYPE FLTY IS DIGITS CONIN; + TYPE FIXY IS DELTA CONFI RANGE 0.0 .. 10.0; + TYPE REAL IS DELTA 0.25 RANGE 0.0 .. 11.0; + TYPE FIXTY IS DELTA 0.25 RANGE 0.0 .. CONFL; + + FUNCTION IDENT_REAL (X : REAL) RETURN REAL; + + PACKAGE P IS + TYPE T IS PRIVATE; + CON1 : CONSTANT T; + PRIVATE + TYPE T IS NEW INTEGER; + CON1 : CONSTANT T := 10; + TYPE NINT IS RANGE 1 .. CON1; + END P; + PACKAGE BODY P IS + TYPE CON2 IS RANGE CON1 .. 50; + BEGIN + IF NINT'LAST /= NINT(IDENT_INT(10)) THEN + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 1"); + END IF; + IF CON2'FIRST /= CON2(IDENT_INT(10)) THEN + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 2"); + END IF; + END P; + + FUNCTION IDENT_REAL (X : REAL) RETURN REAL IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0.0; + END IF; + END IDENT_REAL; + + BEGIN + + IF ITEG'LAST /= ITEG(IDENT_INT(3)) THEN + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 3"); + END IF; + + IF FLTY'DIGITS /= IDENT_INT(3) THEN + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 4"); + END IF; + + IF FIXY'DELTA /= IDENT_REAL(0.25) THEN + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 5"); + END IF; + + IF FIXTY'LAST /= FIXTY(IDENT_REAL(11.0)) THEN + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 6"); + END IF; + + CASE CAS_EN IS + WHEN CONEN => + CAS_EN := RED; + WHEN OTHERS => + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 7"); + END CASE; + + END; + + RESULT; + +END C49023A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c49024a.ada b/gcc/testsuite/ada/acats/tests/c4/c49024a.ada new file mode 100644 index 000000000..df815794a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49024a.ada @@ -0,0 +1,134 @@ +-- C49024A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A FUNCTION CALL CAN APPEAR IN A STATIC EXPRESSION IF THE +-- FUNCTION NAME DENOTES A PREDEFINED OPERATOR AND HAS THE FORM OF AN +-- OPERATOR SYMBOL OR AN EXPANDED NAME WHOSE SELECTOR IS AN OPERATOR +-- SYMBOL. + +-- L.BROWN 10/02/86 + +WITH REPORT; USE REPORT; +PROCEDURE C49024A IS + + PACKAGE P IS + TYPE TY IS NEW INTEGER; + END P; + + CON1 : CONSTANT P.TY := 3; + CON2 : CONSTANT P.TY := 4; + TYPE INT1 IS RANGE 1 .. P."+"(CON1,CON2); + CON3 : CONSTANT := 5; + CON4 : CONSTANT := 7; + TYPE FLT IS DIGITS "-"(CON4,CON3); + TYPE FIX1 IS DELTA 1.0 RANGE 0.0 .. 25.0; + CON5 : CONSTANT := 3.0; + CON6 : CONSTANT := 6.0; + TYPE FIX2 IS DELTA 1.0 RANGE 0.0 .. "/"(CON6,CON5); + TYPE ENUM IS (RED,BLUE,GREEN,BLACK); + CON7 : CONSTANT BOOLEAN := TRUE; + CON8 : CONSTANT ENUM := BLUE; + CAS_INT1 : CONSTANT := 10; + CAS_INT2 : CONSTANT := 2; + OBJ1 : INTEGER := 10; + CAS_BOL : BOOLEAN := TRUE; + CON9 : CONSTANT ENUM := BLACK; + CON10 : CONSTANT FIX1 := 2.0; + CON11 : CONSTANT FIX1 := 10.0; + TYPE FIX3 IS DELTA "+"(CON10) RANGE 0.0 .. 20.0; + TYPE INT2 IS RANGE 0 .. "ABS"("-"(CON4)); + CON12 : CONSTANT CHARACTER := 'D'; + CON13 : CONSTANT CHARACTER := 'B'; + CON14 : CONSTANT BOOLEAN := FALSE; + CON15 : CONSTANT := 10; + +BEGIN + + TEST("C49024A","A FUNCTION CALL CAN BE IN A STATIC EXPRESSION "& + "IF THE FUNCTION NAME DENOTES A PREDEFINED "& + "OPERATOR AND HAS THE FORM OF AN OPERATOR SYMBOL"); + + CASE CAS_BOL IS + WHEN ("NOT"(CON7)) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 1"); + WHEN ("/="(CON8,CON9)) => + OBJ1 := 2; + END CASE; + CAS_BOL := TRUE; + + CASE CAS_BOL IS + WHEN ("*"(CON3,CON4) = CAS_INT1) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 2"); + WHEN ("ABS"(CON15) = CAS_INT1) => + OBJ1 := 3; + END CASE; + CAS_BOL := TRUE; + + CASE CAS_BOL IS + WHEN ("<"(CON11,CON10)) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 3"); + WHEN ("<="(CON13,CON12)) => + OBJ1 := 4; + END CASE; + CAS_BOL := TRUE; + + CASE CAS_BOL IS + WHEN ("REM"(CON4,CON3) = CAS_INT2) => + OBJ1 := 5; + WHEN ("**"(CON3,CON4) = CAS_INT2) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 4"); + END CASE; + + CASE CAS_BOL IS + WHEN (P.">"(CON1,CON2)) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 5"); + WHEN ("OR"(CON7,CON14)) => + OBJ1 := 6; + END CASE; + CAS_BOL := TRUE; + + CASE CAS_BOL IS + WHEN ("MOD"(CON4,CON3) = CAS_INT2) => + OBJ1 := 7; + WHEN ("ABS"(CON4) = CAS_INT2) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 6"); + END CASE; + + CASE CAS_BOL IS + WHEN ("AND"(CON7,CON14)) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 7"); + WHEN (">="(CON12,CON13)) => + OBJ1 := 9; + END CASE; + + RESULT; + +END C49024A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c49025a.ada b/gcc/testsuite/ada/acats/tests/c4/c49025a.ada new file mode 100644 index 000000000..be15cbde2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49025a.ada @@ -0,0 +1,104 @@ +-- C49025A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CERTAIN ATTRIBUTES CAN BE USED IN STATIC EXPRESSIONS +-- SUCH AS: 'SUCC, 'PRED, 'POS, 'VAL, 'AFT, 'DELTA, 'DIGITS, 'FIRST, +--'FORE, 'LAST, 'MACHINE_EMAX, 'MACHINE_EMIN, 'MACHINE_MANTISSA, +--'MACHINE_OVERFLOWS, 'MACHINE_RADIX, 'MACHINE_ROUNDS, 'SIZE, 'SMALL, 'WIDTH. + +-- L.BROWN 10/07/86 +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; + +PROCEDURE C49025A IS + + TYPE ENUM IS (RED,BLUE,GREEN,BLACK); + TYPE FIX IS DELTA 0.125 RANGE 0.0 .. 20.0; + TYPE FLT IS DIGITS 3 RANGE 0.0 .. 25.0; + TYPE INT IS RANGE 1 .. 100; + TYPE TINT1 IS RANGE 1 .. ENUM'POS(BLUE); + TYPE TFLT IS DIGITS FIX'AFT RANGE 0.0 .. 10.0; + TYPE TFIX2 IS DELTA FIX'DELTA RANGE 0.0 .. 5.0; + TYPE TFLT1 IS DIGITS FLT'DIGITS; + TYPE ITN IS RANGE 0 .. INT'FIRST; + TYPE TINT2 IS RANGE 1 .. FIX'FORE; + TYPE TFLT3 IS DIGITS 3 RANGE 5.0 .. FLT'LAST; + CON3 : CONSTANT := FLT'MACHINE_EMAX; + TYPE TINT3 IS RANGE FLT'MACHINE_EMIN .. 1; + CON4 : CONSTANT := FLT'MACHINE_MANTISSA; + TYPE TINT4 IS RANGE 1 .. FLT'MACHINE_RADIX; + CON6 : CONSTANT := INT'SIZE; + TYPE TFIX5 IS DELTA 0.125 RANGE 0.0 .. FIX'SMALL; + TYPE TINT6 IS RANGE 1 .. ENUM'WIDTH; + OBJ1 : INTEGER := 1; + CAS_OBJ : BOOLEAN := TRUE; + +BEGIN + + TEST("C49025A","CHECK THAT CERTAIN ATTRIBUTES CAN "& + "BE USED IN STATIC EXPRESSIONS."); + + CASE CAS_OBJ IS + WHEN (ENUM'PRED(BLUE) = ENUM'(RED)) => + OBJ1 := 2; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 1"); + END CASE; + CAS_OBJ := TRUE; + + CASE CAS_OBJ IS + WHEN (ENUM'SUCC(RED) = ENUM'(BLUE)) => + OBJ1 := 3; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 2"); + END CASE; + CAS_OBJ := TRUE; + + CASE CAS_OBJ IS + WHEN (ENUM'VAL(3) = ENUM'(BLACK)) => + OBJ1 := 4; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 3"); + END CASE; + CAS_OBJ := TRUE; + + CASE CAS_OBJ IS + WHEN (TRUE OR FLT'MACHINE_OVERFLOWS) => + OBJ1 := 5; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 4"); + END CASE; + CAS_OBJ := FALSE; + + CASE CAS_OBJ IS + WHEN (FALSE AND FIX'MACHINE_ROUNDS) => + OBJ1 := 6; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 5"); + END CASE; + + RESULT; + +END C49025A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c49026a.ada b/gcc/testsuite/ada/acats/tests/c4/c49026a.ada new file mode 100644 index 000000000..c4cffa729 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49026a.ada @@ -0,0 +1,59 @@ +-- C49026A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A QUALIFIED EXPRESSION CAN APPEAR IN A STATIC EXPRESSION. + +-- L.BROWN 10/07/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C49026A IS + + TYPE ENUM IS (RED,GREEN,BLUE,YELLOW); + TYPE INT1 IS RANGE 1 .. 50; + TYPE FLT1 IS DIGITS 3 RANGE 1.0 .. 5.0; + TYPE FIX1 IS DELTA 0.125 RANGE 0.0 .. 10.0; + TYPE INT2 IS RANGE 1 .. INT1'(25); + TYPE FLT2 IS DIGITS 3 RANGE 1.0 .. FLT1'(2.0); + TYPE FIX2 IS DELTA 0.125 RANGE 0.0 .. FIX1'(5.0); + TYPE FLT3 IS DIGITS INT1'(3); + TYPE FIX3 IS DELTA FIX1'(0.125) RANGE 0.0 .. 5.0; + OBJ1 : INTEGER := 2; + CAS_OBJ : ENUM := GREEN; + +BEGIN + + TEST("C49026A","QUALIFIED EXPRESSIONS CAN APPEAR IN STATIC "& + "EXPRESSIONS"); + + CASE CAS_OBJ IS + WHEN ENUM'(GREEN) => + OBJ1 := 3; + WHEN OTHERS => + FAILED("INCORRECT VALUE FOR QUALIFIED EXPRESSION 1"); + END CASE; + + RESULT; + +END C49026A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a005b.ada b/gcc/testsuite/ada/acats/tests/c4/c4a005b.ada new file mode 100644 index 000000000..371077f45 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a005b.ada @@ -0,0 +1,104 @@ +-- C4A005B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A NONSTATIC UNIVERSAL INTEGER EXPRESSION RAISES +-- CONSTRAINT_ERROR IF DIVISION BY ZERO IS ATTEMPTED +-- OR IF THE SECOND OPERAND OF REM OR MOD IS ZERO. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- JBG 5/2/85 +-- EG 10/24/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO +-- AI-00387; PREVENT DEAD VARIABLE OPTIMIZATION +-- MRM 03/30/93 REMOVE NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; +PROCEDURE C4A005B IS +BEGIN + TEST("C4A005B", "CHECK CONSTRAINT_ERROR FOR " & + "NONSTATIC UNIVERSAL " & + "INTEGER EXPRESSIONS - DIVISION BY ZERO"); + BEGIN + DECLARE + X : BOOLEAN := 1 = 1/INTEGER'POS(IDENT_INT(0)); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED - DIV"); + IF X /= IDENT_BOOL(X) THEN + FAILED ("WRONG RESULT - DIV"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION IN WRONG PLACE - DIV"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED FOR / BY 0"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DIV"); + END; + + BEGIN + DECLARE + X : BOOLEAN := 1 = 1 REM INTEGER'POS(IDENT_INT(0)); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED - REM"); + IF X /= IDENT_BOOL(X) THEN + FAILED ("WRONG RESULT - REM"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION IN WRONG PLACE - REM"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED FOR REM BY 0"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - REM"); + END; + + BEGIN + DECLARE + X : BOOLEAN := 1 = INTEGER'POS(IDENT_INT(1)) MOD 0; + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED - MOD"); + IF X /= IDENT_BOOL(X) THEN + FAILED ("WRONG RESULT - MOD"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION IN WRONG PLACE - MOD"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED FOR MOD BY 0"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - MOD"); + END; + + RESULT; + +END C4A005B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a006a.ada b/gcc/testsuite/ada/acats/tests/c4/c4a006a.ada new file mode 100644 index 000000000..5ba984a7a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a006a.ada @@ -0,0 +1,61 @@ +-- C4A006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A UNIVERSAL_INTEGER +-- EXPRESSION CONTAINING AN EXPONENTIATION OPERATOR IF THE EXPONENT +-- HAS A NEGATIVE VALUE. + +-- BAW 9/29/80 +-- SPS 4/7/82 +-- TBN 10/23/85 RENAMED FROM B4A006A-B.ADA. REVISED TO CHECK FOR +-- CONSTRAINT_ERROR WHEN EXPONENT IS NEGATIVE IN +-- A NONSTATIC CONTEXT. + +WITH REPORT; USE REPORT; +PROCEDURE C4A006A IS + +BEGIN + TEST ("C4A006A", "CHECK THAT A NEGATIVE EXPONENT IN " & + "UNIVERSAL_INTEGER EXPONENTIATION RAISES " & + "CONSTRAINT_ERROR"); + + DECLARE + B : BOOLEAN; + BEGIN + + B := (1 ** IDENT_INT(-1)) = 1; + FAILED ("EXCEPTION NOT RAISED"); + IF NOT B THEN + FAILED ("(1 ** (-1)) /= 1"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + RESULT; +END C4A006A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a007a.tst b/gcc/testsuite/ada/acats/tests/c4/c4a007a.tst new file mode 100644 index 000000000..56850ca3e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a007a.tst @@ -0,0 +1,47 @@ +-- C4A007A.TST + +-- 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. +--* +-- USE OF MAX_INT IN NUMBER DECLARATION + +-- BAW 29 SEPT 80 + +WITH REPORT; +PROCEDURE C4A007A IS + + USE REPORT; + + X : CONSTANT := $MAX_INT - ($MAX_INT MOD 2); + Y : CONSTANT := ($MAX_INT / 2) * 2; + +BEGIN TEST("C4A007A","USING THE INTEGER VALUE MAX_INT IN NUMBER " & + " DECLARATIONS "); + + IF X /= Y + THEN FAILED("USING THE INTEGER VALUE MAX_INT GIVES " & + " GIVES WRONG RESULTS "); + END IF; + + RESULT; + +END C4A007A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a010a.ada b/gcc/testsuite/ada/acats/tests/c4/c4a010a.ada new file mode 100644 index 000000000..e6dfe7e38 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a010a.ada @@ -0,0 +1,80 @@ +-- C4A010A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT STATIC UNIVERSAL_REAL EXPRESSIONS ARE EVALUATED EXACTLY. + +-- SMALL RATIONAL NUMBERS ARE USED IN THIS TEST. + +-- JBG 5/3/85 + +WITH REPORT; USE REPORT; +PROCEDURE C4A010A IS + + C13 : CONSTANT := 1.0/3.0; + C47 : CONSTANT := 4.0/7.0; + C112: CONSTANT := 13.0/12.0; + HALF: CONSTANT := 3.5/7.0; + +BEGIN + + TEST ("C4A010A", "CHECK STATIC UNIVERSAL_REAL ACCURACY FOR " & + "SMALL RATIONAL NUMBERS"); + + IF C13 - C47 /= -5.0/21.0 THEN + FAILED ("REAL SUBTRACTION RESULT INCORRECT"); + END IF; + + IF C47 + C112 = 1.0 + 55.0/84.0 THEN + NULL; + ELSE + FAILED ("REAL ADDITION RESULT INCORRECT"); + END IF; + + IF C112 - C13 /= 6.0/8.0 THEN + FAILED ("LCD NOT FOUND"); + END IF; + + IF 0.1 * 0.1 /= 0.01 THEN + FAILED ("REAL MULTIPLICATION RESULT INCORRECT"); + END IF; + + IF C112/C13 /= 13.0/4 THEN + FAILED ("REAL QUOTIENT RESULT INCORRECT"); + END IF; + + IF 0.1 ** 4 /= 0.0001 THEN + FAILED ("POSITIVE EXPONENTIATION RESULT INCORRECT"); + END IF; + + IF C13 ** (-3) /= 27.0 * 0.5 * 2 THEN + FAILED ("NEGATIVE EXPONENTIATION RESULT INCORRECT"); + END IF; + + IF HALF /= 0.1/0.2 THEN + FAILED ("FRACTIONAL NUMERATOR AND DENOMINATOR"); + END IF; + + RESULT; + +END C4A010A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a010b.ada b/gcc/testsuite/ada/acats/tests/c4/c4a010b.ada new file mode 100644 index 000000000..31cf3d9de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a010b.ada @@ -0,0 +1,82 @@ +-- C4A010B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT STATIC UNIVERSAL REAL EXPRESSIONS ARE EVALUATED +-- EXACTLY. IN PARTICULAR, CHECK THAT THE CASCADING USE OF FRACTIONAL +-- VALUES DOES NOT RESULT IN THE LOSS OF PRECISION. + +-- RJW 7/31/86 + +WITH REPORT; USE REPORT; +PROCEDURE C4A010B IS + + +BEGIN + + TEST( "C4A010B", "CHECK THAT STATIC UNIVERSAL REAL EXPRESSIONS " & + "ARE EVALUATED EXACTLY. IN PARTICULAR, CHECK " & + "THAT THE CASCADING USE OF FRACTIONAL VALUES " & + "DOES NOT RESULT IN THE LOSS OF PRECISION" ); + + DECLARE + B : CONSTANT := 2.0/3.0; + + X0 : CONSTANT := 1.0; + X1 : CONSTANT := X0 + B; + X2 : CONSTANT := X1 + B ** 2; + X3 : CONSTANT := X2 + B ** 3; + X4 : CONSTANT := X3 + B ** 4; + X5 : CONSTANT := X4 + B ** 5; + X6 : CONSTANT := X5 + B ** 6; + X7 : CONSTANT := X6 + B ** 7; + X8 : CONSTANT := X7 + B ** 8; + X9 : CONSTANT := X8 + B ** 9; + + Y1 : CONSTANT := B ** 10; + Y2 : CONSTANT := 1.0; + Y3 : CONSTANT := Y1 - Y2; + Y4 : CONSTANT := B; + Y5 : CONSTANT := Y4 - Y2; + Y6 : CONSTANT := Y3 / Y5; + + BEGIN + IF X9 /= 58025.0/19683.0 THEN + FAILED ( "INCORRECT RESULTS FOR SERIES OF NAMED " & + "NUMBERS - 1" ); + END IF; + + IF Y6 /= 58025.0/19683.0 THEN + FAILED ( "INCORRECT RESULTS FOR SERIES OF NAMED " & + "NUMBERS - 2" ); + END IF; + + IF X9 /= Y6 THEN + FAILED ( "INCORRECT RESULTS FOR SERIES OF NAMED " & + "NUMBERS - 3" ); + END IF; + + END; + + RESULT; +END C4A010B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a011a.ada b/gcc/testsuite/ada/acats/tests/c4/c4a011a.ada new file mode 100644 index 000000000..374827cc9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a011a.ada @@ -0,0 +1,334 @@ +-- C4A011A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT NONSTATIC UNIVERSAL REAL EXPRESSIONS ARE EVALUATED WITH +-- THE ACCURACY OF THE MOST PRECISE PREDEFINED FLOATING POINT TYPE +-- (I. E., THE TYPE FOR WHICH 'DIGITS EQUALS SYSTEM.MAX_DIGITS). + +-- RJW 8/4/86 + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C4A011A IS + + TYPE MAX_FLOAT IS DIGITS MAX_DIGITS; + + C5L : CONSTANT := 16#0.AAAA8#; + C5U : CONSTANT := 16#0.AAAAC#; + + C6L : CONSTANT := 16#0.AAAAA8#; + C6U : CONSTANT := 16#0.AAAAB0#; + + C7L : CONSTANT := 16#0.AAAAAA8#; + C7U : CONSTANT := 16#0.AAAAAB0#; + + C8L : CONSTANT := 16#0.AAAAAAA#; + C8U : CONSTANT := 16#0.AAAAAAB#; + + C9L : CONSTANT := 16#0.AAAAAAAA#; + C9U : CONSTANT := 16#0.AAAAAAAC#; + + C10L : CONSTANT := 16#0.AAAAAAAAA#; + C10U : CONSTANT := 16#0.AAAAAAAAC#; + + C11L : CONSTANT := 16#0.AAAAAAAAA8#; + C11U : CONSTANT := 16#0.AAAAAAAAAC#; + + C12L : CONSTANT := 16#0.AAAAAAAAAA8#; + C12U : CONSTANT := 16#0.AAAAAAAAAB0#; + + C13L : CONSTANT := 16#0.AAAAAAAAAAA8#; + C13U : CONSTANT := 16#0.AAAAAAAAAAB0#; + + C14L : CONSTANT := 16#0.AAAAAAAAAAAA#; + C14U : CONSTANT := 16#0.AAAAAAAAAAAB#; + + C15L : CONSTANT := 16#0.AAAAAAAAAAAAA#; + C15U : CONSTANT := 16#0.AAAAAAAAAAAAC#; + + C16L : CONSTANT := 16#0.AAAAAAAAAAAAAA#; + C16U : CONSTANT := 16#0.AAAAAAAAAAAAAC#; + + C17L : CONSTANT := 16#0.AAAAAAAAAAAAAA8#; + C17U : CONSTANT := 16#0.AAAAAAAAAAAAAAC#; + + C18L : CONSTANT := 16#0.AAAAAAAAAAAAAAA8#; + C18U : CONSTANT := 16#0.AAAAAAAAAAAAAAB0#; + + C19L : CONSTANT := 16#0.AAAAAAAAAAAAAAAA8#; + C19U : CONSTANT := 16#0.AAAAAAAAAAAAAAAB0#; + + C20L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAA#; + C20U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAB#; + + C21L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAA#; + C21U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAC#; + + C22L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAA#; + C22U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAC#; + + C23L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAA8#; + C23U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAC#; + + C24L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAA8#; + C24U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAB0#; + + C25L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAA8#; + C25U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAB0#; + + C26L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAA#; + C26U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAB#; + + C27L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAA#; + C27U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAC#; + + C28L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAA#; + C28U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAC#; + + C29L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAA8#; + C29U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAC#; + + C30L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAA8#; + C30U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAB0#; + + C31L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAA#; + C31U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAB#; + + C32L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAA#; + C32U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAB#; + + C33L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAA#; + C33U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAC#; + + C34L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAA8#; + C34U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAAC#; + + C35L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAAA8#; + C35U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAAAC#; + +BEGIN + + TEST ( "C4A011A", "CHECK THAT NONSTATIC UNIVERSAL REAL " & + "EXPRESSIONS ARE EVALUATED WITH THE " & + "ACCURACY OF THE MOST PRECISE PREDEFINED " & + "FLOATING POINT TYPE (I. E., THE TYPE FOR " & + "WHICH 'DIGITS EQUALS SYSTEM.MAX_DIGITS" ); + + CASE MAX_DIGITS IS + WHEN 5 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C5L .. C5U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 5" ); + END IF; + WHEN 6 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C6L .. C6U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 6" ); + END IF; + WHEN 7 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C7L .. C7U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 7" ); + END IF; + WHEN 8 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C8L .. C8U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 8" ); + END IF; + WHEN 9 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C9L .. C9U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 9" ); + END IF; + WHEN 10 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C10L .. C10U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 10" ); + END IF; + WHEN 11 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C11L .. C11U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 11" ); + END IF; + WHEN 12 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C12L .. C12U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 12" ); + END IF; + WHEN 13 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C13L .. C13U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 13" ); + END IF; + WHEN 14 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C14L .. C14U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 14" ); + END IF; + WHEN 15 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C15L .. C15U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 15" ); + END IF; + WHEN 16 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C16L .. C16U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 16" ); + END IF; + WHEN 17 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C17L .. C17U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 17" ); + END IF; + WHEN 18 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C18L .. C18U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 18" ); + END IF; + WHEN 19 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C19L .. C19U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 19" ); + END IF; + WHEN 20 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C20L .. C20U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 20" ); + END IF; + WHEN 21 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C21L .. C21U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 21" ); + END IF; + WHEN 22 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C22L .. C22U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 22" ); + END IF; + WHEN 23 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C23L .. C23U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 23" ); + END IF; + WHEN 24 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C24L .. C24U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 24" ); + END IF; + WHEN 25 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C25L .. C25U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 25" ); + END IF; + WHEN 26 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C26L .. C26U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 26" ); + END IF; + WHEN 27 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C27L .. C27U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 27" ); + END IF; + WHEN 28 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C28L .. C28U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 28" ); + END IF; + WHEN 29 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C29L .. C29U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 29" ); + END IF; + WHEN 30 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C30L .. C30U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 30" ); + END IF; + WHEN 31 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C31L .. C31U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 31" ); + END IF; + WHEN 32 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C32L .. C32U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 32" ); + END IF; + WHEN 33 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C33L .. C33U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 33" ); + END IF; + WHEN 34 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C34L .. C34U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 34" ); + END IF; + WHEN 35 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C35L .. C35U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 35" ); + END IF; + WHEN OTHERS => + NOT_APPLICABLE ( "MAX_DIGITS OUT OF RANGE OF TEST. " & + "MAX_DIGITS = " & + INTEGER'IMAGE (MAX_DIGITS)); + END CASE; + + RESULT; + +END C4A011A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a012b.ada b/gcc/testsuite/ada/acats/tests/c4/c4a012b.ada new file mode 100644 index 000000000..70c23ad94 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a012b.ada @@ -0,0 +1,184 @@ +-- C4A012B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR +-- A UNIVERSAL_REAL EXPRESSION IF DIVISION BY ZERO IS ATTEMPTED. + +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR +-- 0.0 ** (-1) (OR ANY OTHER NEGATIVE EXPONENT VALUE). + +-- HISTORY: +-- RJW 09/04/86 CREATED ORIGINAL TEST. +-- CJJ 09/04/87 ADDED PASS MESSAGE FOR RAISING NUMERIC_ERROR; +-- MODIFIED CODE TO PREVENT COMPILER OPTIMIZING +-- OUT THE TEST. +-- JET 12/31/87 ADDED MORE CODE TO PREVENT OPTIMIZATION. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY +-- JRL 02/29/96 Added code to check for value of Machine_Overflows; if +-- False, test is inapplicable. + +WITH REPORT; USE REPORT; + +PROCEDURE C4A012B IS + + F : FLOAT; + + I3 : INTEGER := -3; + + SUBTYPE SINT IS INTEGER RANGE -10 .. 10; + SI5 : CONSTANT SINT := -5; + + FUNCTION IDENT (X:FLOAT) RETURN FLOAT IS + BEGIN + IF EQUAL (3,3) THEN + RETURN X; + ELSE + RETURN 1.0; + END IF; + END IDENT; + +BEGIN + + TEST ( "C4A012B", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED FOR " & + "0.0 ** (-1) (OR ANY OTHER NEGATIVE EXPONENT " & + "VALUE)" ); + + IF FLOAT'MACHINE_OVERFLOWS = FALSE THEN + REPORT.NOT_APPLICABLE ("Float'Machine_Overflows = False"); + ELSE + + BEGIN + F := IDENT (0.0) ** (-1); + FAILED ( "THE EXPRESSION '0.0 ** (-1)' DID NOT RAISE " & + "AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 1"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** (-1)' RAISED THE " & + "WRONG EXCEPTION" ); + END; + + BEGIN + F := 0.0 ** (IDENT_INT (-1)); + FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (-1))' DID " & + "NOT RAISE AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 2"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (-1))' " & + "RAISED THE WRONG EXCEPTION" ); + END; + + BEGIN + F := 0.0 ** (INTEGER'POS (IDENT_INT (-1))); + FAILED ( "THE EXPRESSION '0.0 ** " & + "(INTEGER'POS (IDENT_INT (-1)))' DID " & + "NOT RAISE AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 3"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** " & + "(INTEGER'POS (IDENT_INT (-1)))' RAISED " & + "THE WRONG EXCEPTION" ); + END; + + BEGIN + F := IDENT(0.0) ** I3; + FAILED ( "THE EXPRESSION '0.0 ** I3' DID NOT RAISE " & + "AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 4"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** I3' RAISED THE " & + "WRONG EXCEPTION" ); + END; + + BEGIN + F := 0.0 ** (IDENT_INT (I3)); + FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (I3))' DID " & + "NOT RAISE AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 5"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (I3))' " & + "RAISED THE WRONG EXCEPTION" ); + END; + + BEGIN + F := IDENT (0.0) ** SI5; + FAILED ( "THE EXPRESSION '0.0 ** SI5' DID NOT RAISE " & + "AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 6"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** SI5' RAISED THE " & + "WRONG EXCEPTION" ); + END; + + BEGIN + F := 0.0 ** (IDENT_INT (SI5)); + FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (SI5))' DID " & + "NOT RAISE AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 7"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (SI5))' " & + "RAISED THE WRONG EXCEPTION" ); + END; + + END IF; + + RESULT; + +END C4A012B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a013a.ada b/gcc/testsuite/ada/acats/tests/c4/c4a013a.ada new file mode 100644 index 000000000..1f385b5b4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a013a.ada @@ -0,0 +1,77 @@ +-- C4A013A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A NONSTATIC +-- UNIVERSAL_REAL EXPRESSION IF THE VALUE WOULD LIE OUTSIDE THE RANGE OF +-- THE BASE TYPE OF THE MOST ACCURATE PREDEFINED FLOATING POINT TYPE AND +-- MACHINE_OVERFLOWS IS TRUE FOR THAT TYPE. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- BAW 29 SEPT 80 +-- TBN 10/30/85 RENAMED FROM C4A013A.ADA. +-- JRK 1/13/86 COMPLETELY REVISED TO CHECK NONSTATIC UNIVERSAL_REAL +-- EXPRESSIONS WHOSE RESULTS OVERFLOW. REVISED +-- NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO +-- AI-00387. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH SYSTEM, REPORT; +USE SYSTEM, REPORT; + +PROCEDURE C4A013A IS + + TYPE F IS DIGITS MAX_DIGITS; + + B : BOOLEAN; + +BEGIN + TEST ("C4A013A", "CHECK NONSTATIC UNIVERSAL_REAL EXPRESSIONS " & + "WHOSE RESULTS OVERFLOW"); + + BEGIN + B := 1.0 < 1.0 / (1.0 * INTEGER'POS (IDENT_INT (0))); + + IF F'MACHINE_OVERFLOWS THEN + FAILED ("MACHINE_OVERFLOWS IS TRUE, BUT NO EXCEPTION " & + "WAS RAISED"); + ELSE COMMENT ("MACHINE_OVERFLOWS IS FALSE AND NO EXCEPTION " & + "WAS RAISED"); + END IF; + + IF NOT B THEN -- USE B TO PREVENT DEAD VARIABLE OPTIMIZATION. + COMMENT ("1.0 < 1.0 / 0.0 YIELDS FALSE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + RESULT; +END C4A013A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c4a014a.ada b/gcc/testsuite/ada/acats/tests/c4/c4a014a.ada new file mode 100644 index 000000000..84aa878c5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a014a.ada @@ -0,0 +1,86 @@ +-- C4A014A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ROUNDING IS DONE CORRECTLY FOR STATIC UNIVERSAL REAL +-- EXPRESSIONS. + +-- JBG 5/3/85 +-- JBG 11/3/85 DECLARE INTEGER CONSTANTS INSTEAD OF UNIVERSAL INTEGER +-- DTN 11/27/91 DELETED SUBPART (B). + +WITH REPORT; USE REPORT; +PROCEDURE C4A014A IS + + C15 : CONSTANT := 1.5; + C25 : CONSTANT := 2.5; + CN15 : CONSTANT := -1.5; + CN25 : CONSTANT := -2.5; + + C15R : CONSTANT INTEGER := INTEGER(C15); + C25R : CONSTANT INTEGER := INTEGER(C25); + CN15R : CONSTANT INTEGER := INTEGER(CN15); + CN25R : CONSTANT INTEGER := INTEGER(CN25); + + C15_1 : BOOLEAN := 1 = C15R; + C15_2 : BOOLEAN := 2 = C15R; + C25_2 : BOOLEAN := 2 = C25R; + C25_3 : BOOLEAN := 3 = C25R; + + CN15_N1 : BOOLEAN := -1 = CN15R; + CN15_N2 : BOOLEAN := -2 = CN15R; + CN25_N2 : BOOLEAN := -2 = CN25R; + CN25_N3 : BOOLEAN := -3 = CN25R; + +BEGIN + + TEST ("C4A014A", "CHECK ROUNDING TO INTEGER FOR UNIVERSAL REAL " & + "EXPRESSIONS"); + + IF 1 /= INTEGER(1.4) THEN + FAILED ("INTEGER(1.4) DOES NOT EQUAL 1"); + END IF; + + IF 2 /= INTEGER(1.6) THEN + FAILED ("INTEGER(1.6) DOES NOT EQUAL 2"); + END IF; + + IF -1 /= INTEGER(-1.4) THEN + FAILED ("INTEGER(-1.4) DOES NOT EQUAL -1"); + END IF; + + IF -2 /= INTEGER(-1.6) THEN + FAILED ("INTEGER(-1.6) DOES NOT EQUAL -2"); + END IF; + + IF NOT (C15_1 OR C15_2) OR (NOT (C25_2 OR C25_3)) THEN + FAILED ("ROUNDING OF POSITIVE VALUES NOT CORRECT"); + END IF; + + IF NOT (CN15_N1 OR CN15_N2) OR (NOT (CN25_N2 OR CN25_N3)) THEN + FAILED ("ROUNDING OF NEGATIVE VALUES NOT CORRECT"); + END IF; + + RESULT; + +END C4A014A; |