From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; 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. --- gcc/testsuite/ada/acats/tests/cc/cc1311a.ada | 480 +++++++++++++++++++++++++++ 1 file changed, 480 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1311a.ada (limited to 'gcc/testsuite/ada/acats/tests/cc/cc1311a.ada') diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada b/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada new file mode 100644 index 000000000..ce38abe55 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada @@ -0,0 +1,480 @@ +-- CC1311A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF 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 DEFAULT EXPRESSIONS OF THE PARAMETERS OF A FORMAL +-- SUBPROGRAM ARE USED INSTEAD OF THE DEFAULTS (IF ANY) OF THE +-- ACTUAL SUBPROGRAM PARAMETER. + +-- HISTORY: +-- RJW 06/05/86 CREATED ORIGINAL TEST. +-- VCL 08/18/87 CHANGED A COUPLE OF STATIC DEFAULT EXPRESSIONS FOR +-- FORMAL SUBPROGRAM PARAMETERS TO DYNAMIC +-- EXPRESSIONS VIA THE USE OF THE IDENTITY FUNCTION. +-- EDWARD V. BERARD 08/13/90 +-- ADDED CHECKS FOR MULTI-DIMENSIONAL ARRAYS. + +WITH REPORT ; + +PROCEDURE CC1311A IS + + TYPE NUMBERS IS (ZERO, ONE ,TWO); + + SHORT_START : CONSTANT := -100 ; + SHORT_END : CONSTANT := 100 ; + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + + SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + + SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ; + + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (MONTH => AUG, + DAY => 8, + YEAR => 1990) ; + + FIRST_DATE : DATE := (DAY => 6, + MONTH => JUN, + YEAR => 1967) ; + + SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ; + + TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT, + FIRST_HALF, + FIRST_FIVE) OF DATE ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH FUNCTION FUN (FIRST : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE)))) + RETURN CUBE ; + + PROCEDURE PROC_WITH_3D_FUNC ; + + PROCEDURE PROC_WITH_3D_FUNC IS + + BEGIN -- PROC_WITH_3D_FUNC + + IF FUN /= CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " & + "ARRAY, FUNCTION, AND PROCEDURE.") ; + END IF ; + + END PROC_WITH_3D_FUNC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH FUNCTION FUN (FIRST : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE)))) + RETURN CUBE ; + + PACKAGE PKG_WITH_3D_FUNC IS + END PKG_WITH_3D_FUNC ; + + PACKAGE BODY PKG_WITH_3D_FUNC IS + BEGIN -- PKG_WITH_3D_FUNC + + REPORT.TEST("CC1311A","CHECK THAT THE DEFAULT EXPRESSIONS " & + "OF THE PARAMETERS OF A FORMAL SUBPROGRAM ARE " & + "USED INSTEAD OF THE DEFAULTS (IF ANY) OF THE " & + "ACTUAL SUBPROGRAM PARAMETER" ) ; + + IF FUN /= CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " & + "ARRAY, FUNCTION, AND PACKAGE.") ; + END IF ; + + END PKG_WITH_3D_FUNC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH FUNCTION FUN (FIRST : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE)))) + RETURN CUBE ; + + FUNCTION FUNC_WITH_3D_FUNC RETURN BOOLEAN ; + + FUNCTION FUNC_WITH_3D_FUNC RETURN BOOLEAN IS + BEGIN -- FUNC_WITH_3D_FUNC + + RETURN FUN = CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) ; + + END FUNC_WITH_3D_FUNC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH PROCEDURE PROC (INPUT : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE))) ; + OUTPUT : OUT CUBE) ; + + PROCEDURE PROC_WITH_3D_PROC ; + + PROCEDURE PROC_WITH_3D_PROC IS + + RESULTS : CUBE ; + + BEGIN -- PROC_WITH_3D_PROC + + PROC (OUTPUT => RESULTS) ; + + IF RESULTS /= CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " & + "ARRAY, PROCEDURE, AND PROCEDURE.") ; + END IF ; + + END PROC_WITH_3D_PROC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH PROCEDURE PROC (INPUT : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE))) ; + OUTPUT : OUT CUBE) ; + + PACKAGE PKG_WITH_3D_PROC IS + END PKG_WITH_3D_PROC ; + + PACKAGE BODY PKG_WITH_3D_PROC IS + + RESULTS : CUBE ; + + BEGIN -- PKG_WITH_3D_PROC + + PROC (OUTPUT => RESULTS) ; + + IF RESULTS /= CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " & + "ARRAY, PROCEDURE, AND PACKAGE.") ; + END IF ; + + END PKG_WITH_3D_PROC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH PROCEDURE PROC (INPUT : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE))) ; + OUTPUT : OUT CUBE) ; + + FUNCTION FUNC_WITH_3D_PROC RETURN BOOLEAN ; + + FUNCTION FUNC_WITH_3D_PROC RETURN BOOLEAN IS + + RESULTS : CUBE ; + + BEGIN -- FUNC_WITH_3D_PROC + + PROC (OUTPUT => RESULTS) ; + RETURN RESULTS = CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) ; + + END FUNC_WITH_3D_PROC ; + + GENERIC + TYPE T IS (<>); + WITH FUNCTION F (X : T := T'VAL (0)) RETURN T; + FUNCTION FUNC1 RETURN BOOLEAN; + + FUNCTION FUNC1 RETURN BOOLEAN IS + BEGIN -- FUNC1 + RETURN F = T'VAL (0); + END FUNC1; + + GENERIC + TYPE T IS (<>); + WITH FUNCTION F (X : T := T'VAL (REPORT.IDENT_INT(0))) + RETURN T; + PACKAGE PKG1 IS END PKG1; + + PACKAGE BODY PKG1 IS + BEGIN -- PKG1 + IF F /= T'VAL (0) THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " & + "FUNCTION 'F' AND PACKAGE 'PKG1'" ); + END IF; + END PKG1; + GENERIC + TYPE T IS (<>); + WITH FUNCTION F (X : T := T'VAL (0)) RETURN T; + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN -- PROC1 + IF F /= T'VAL (0) THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " & + "FUNCTION 'F' AND PROCEDURE 'PROC1'" ); + END IF; + END PROC1; + + GENERIC + TYPE T IS (<>); + WITH PROCEDURE P (RESULTS : OUT T ; + X : T := T'VAL (0)) ; + FUNCTION FUNC2 RETURN BOOLEAN; + + FUNCTION FUNC2 RETURN BOOLEAN IS + RESULTS : T; + BEGIN -- FUNC2 + P (RESULTS); + RETURN RESULTS = T'VAL (0); + END FUNC2; + + GENERIC + TYPE T IS (<>); + WITH PROCEDURE P (RESULTS : OUT T; + X : T := T'VAL(REPORT.IDENT_INT(0))); + PACKAGE PKG2 IS END PKG2 ; + + PACKAGE BODY PKG2 IS + RESULTS : T; + BEGIN -- PKG2 + P (RESULTS); + IF RESULTS /= T'VAL (0) THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " & + "PROCEDURE 'P' AND PACKAGE 'PKG2'" ); + END IF; + END PKG2; + + GENERIC + TYPE T IS (<>); + WITH PROCEDURE P (RESULTS :OUT T; X : T := T'VAL (0)); + PROCEDURE PROC2; + + PROCEDURE PROC2 IS + RESULTS : T; + BEGIN -- PROC2 + P (RESULTS); + IF RESULTS /= T'VAL (0) THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " & + "PROCEDURE 'P' AND PROCEDURE 'PROC2'" ); + END IF; + END PROC2; + + FUNCTION F1 (A : NUMBERS := ONE) RETURN NUMBERS IS + BEGIN -- F1 + RETURN A; + END; + + PROCEDURE P2 (OUTVAR : OUT NUMBERS; INVAR : NUMBERS := TWO) IS + BEGIN -- P2 + OUTVAR := INVAR; + END; + + FUNCTION TD_FUNC (FIRST : IN THREE_DIMENSIONAL := + (THREE_DIMENSIONAL'RANGE => + (THREE_DIMENSIONAL'RANGE (2) => + (THREE_DIMENSIONAL'RANGE (3) => + FIRST_DATE)))) + RETURN THREE_DIMENSIONAL IS + + BEGIN -- TD_FUNC + + RETURN FIRST ; + + END TD_FUNC ; + + PROCEDURE TD_PROC (INPUT : IN THREE_DIMENSIONAL := + (THREE_DIMENSIONAL'RANGE => + (THREE_DIMENSIONAL'RANGE (2) => + (THREE_DIMENSIONAL'RANGE (3) => + FIRST_DATE))) ; + OUTPUT : OUT THREE_DIMENSIONAL) IS + BEGIN -- TD_PROC + + OUTPUT := INPUT ; + + END TD_PROC ; + + PROCEDURE NEW_PROC_WITH_3D_FUNC IS NEW + PROC_WITH_3D_FUNC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + FUN => TD_FUNC) ; + + PACKAGE NEW_PKG_WITH_3D_FUNC IS NEW + PKG_WITH_3D_FUNC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + FUN => TD_FUNC) ; + + FUNCTION NEW_FUNC_WITH_3D_FUNC IS NEW + FUNC_WITH_3D_FUNC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + FUN => TD_FUNC) ; + + PROCEDURE NEW_PROC_WITH_3D_PROC IS NEW + PROC_WITH_3D_PROC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + PROC => TD_PROC) ; + + PACKAGE NEW_PKG_WITH_3D_PROC IS NEW + PKG_WITH_3D_PROC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + PROC => TD_PROC) ; + + FUNCTION NEW_FUNC_WITH_3D_PROC IS NEW + FUNC_WITH_3D_PROC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + PROC => TD_PROC) ; + + FUNCTION NFUNC1 IS NEW FUNC1 (NUMBERS, F1); + PACKAGE NPKG1 IS NEW PKG1 (NUMBERS, F1); + PROCEDURE NPROC1 IS NEW PROC1 (NUMBERS, F1); + + FUNCTION NFUNC2 IS NEW FUNC2 (NUMBERS, P2); + PACKAGE NPKG2 IS NEW PKG2 (NUMBERS, P2); + PROCEDURE NPROC2 IS NEW PROC2 (NUMBERS, P2); + +BEGIN -- CC1311A + + IF NOT NFUNC1 THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE " & + "WITH FUNCTION 'NFUNC1'" ) ; + END IF ; + + IF NOT NFUNC2 THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE " & + "WITH FUNCTION 'NFUNC2'" ) ; + END IF ; + + NPROC1 ; + NPROC2 ; + + NEW_PROC_WITH_3D_FUNC ; + + IF NOT NEW_FUNC_WITH_3D_FUNC THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL ARRAY, " & + "FUNCTION, AND FUNCTION.") ; + END IF ; + + NEW_PROC_WITH_3D_PROC ; + + IF NOT NEW_FUNC_WITH_3D_PROC THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL ARRAY, " & + "FUNCTION, AND PROCEDURE.") ; + END IF ; + + REPORT.RESULT ; + +END CC1311A ; -- cgit v1.2.3