| -- CC1111A.ADA |
| |
| -- Grant of Unlimited Rights |
| -- |
| -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, |
| -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained |
| -- unlimited rights in the software and documentation contained herein. |
| -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making |
| -- this public release, the Government intends to confer upon all |
| -- recipients unlimited rights equal to those held by the Government. |
| -- These rights include rights to use, duplicate, release or disclose the |
| -- released technical data and computer software in whole or in part, in |
| -- any manner and for any purpose whatsoever, and to have or permit others |
| -- to do so. |
| -- |
| -- DISCLAIMER |
| -- |
| -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR |
| -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED |
| -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE |
| -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE |
| -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A |
| -- PARTICULAR PURPOSE OF SAID MATERIAL. |
| --* |
| -- OBJECTIVE: |
| -- CHECK THAT AFTER A GENERIC UNIT IS INSTANTIATED, THE SUBTYPE OF |
| -- AN IN OUT OBJECT PARAMETER IS DETERMINED BY THE ACTUAL PARAMETER |
| -- (TESTS INTEGER, ENUMERATION, FLOATING POINT, FIXED POINT, ARRAY, |
| -- ACCESS, AND DISCRIMINATED TYPES). |
| |
| -- HISTORY: |
| -- BCB 03/28/88 CREATED ORIGINAL TEST. |
| -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. |
| |
| WITH REPORT; USE REPORT; |
| |
| PROCEDURE CC1111A IS |
| |
| SUBTYPE INT IS INTEGER RANGE 0..5; |
| INTVAR : INTEGER RANGE 1..3; |
| |
| TYPE ENUM IS (ONE, TWO, THREE, FOUR, FIVE, SIX, SEVEN, EIGHT); |
| SUBTYPE SUBENUM IS ENUM RANGE ONE .. FIVE; |
| ENUMVAR : ENUM RANGE TWO .. THREE; |
| |
| TYPE FLT IS DIGITS 5 RANGE -5.0 .. 5.0; |
| SUBTYPE SUBFLT IS FLT RANGE -1.0 .. 1.0; |
| FLTVAR : FLT RANGE 0.0 .. 1.0; |
| |
| TYPE FIX IS DELTA 0.5 RANGE -5.0 .. 5.0; |
| SUBTYPE SUBFIX IS FIX RANGE -1.0 .. 1.0; |
| FIXVAR : FIX RANGE 0.0 .. 1.0; |
| |
| SUBTYPE STR IS STRING (1..10); |
| STRVAR : STRING (1..5); |
| |
| TYPE REC (DISC : INTEGER := 5) IS RECORD |
| NULL; |
| END RECORD; |
| SUBTYPE SUBREC IS REC (6); |
| RECVAR : REC(5); |
| SUBRECVAR : SUBREC; |
| |
| TYPE ACCREC IS ACCESS REC; |
| SUBTYPE A1 IS ACCREC(1); |
| SUBTYPE A2 IS ACCREC(2); |
| A1VAR : A1 := NEW REC(1); |
| A2VAR : A2 := NEW REC(2); |
| |
| PACKAGE P IS |
| TYPE PRIV IS PRIVATE; |
| PRIVATE |
| TYPE PRIV IS RANGE 1 .. 100; |
| SUBTYPE SUBPRIV IS PRIV RANGE 5 .. 10; |
| PRIVVAR : PRIV RANGE 8 .. 10; |
| END P; |
| |
| PACKAGE BODY P IS |
| FUNCTION PRIVEQUAL (ONE, TWO : SUBPRIV) RETURN BOOLEAN; |
| |
| FUNCTION PRIVEQUAL (ONE, TWO : SUBPRIV) RETURN BOOLEAN IS |
| BEGIN |
| RETURN ONE = TWO; |
| END PRIVEQUAL; |
| |
| GENERIC |
| INPUT : SUBPRIV; |
| OUTPUT : IN OUT SUBPRIV; |
| PROCEDURE I; |
| |
| PROCEDURE I IS |
| BEGIN |
| OUTPUT := INPUT; |
| FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & |
| "PRIVATE TYPE"); |
| IF PRIVEQUAL (OUTPUT, OUTPUT) THEN |
| COMMENT ("DON'T OPTIMIZE OUTPUT"); |
| END IF; |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| NULL; |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED"); |
| END I; |
| |
| PROCEDURE I1 IS NEW I (5, PRIVVAR); |
| PROCEDURE I2 IS NEW I (SUBPRIV'FIRST, PRIVVAR); |
| |
| BEGIN |
| TEST ("CC1111A", "CHECK THAT AFTER A GENERIC UNIT IS " & |
| "INSTANTIATED, THE SUBTYPE OF AN IN OUT " & |
| "OBJECT PARAMETER IS DETERMINED BY THE " & |
| "ACTUAL PARAMETER (TESTS INTEGER, " & |
| "ENUMERATION, FLOATING POINT, FIXED POINT " & |
| ", ARRAY, ACCESS, AND DISCRIMINATED TYPES)"); |
| |
| I1; |
| I2; |
| END P; |
| |
| USE P; |
| |
| GENERIC |
| TYPE GP IS PRIVATE; |
| FUNCTION GEN_IDENT (X : GP) RETURN GP; |
| |
| GENERIC |
| INPUT : INT; |
| OUTPUT : IN OUT INT; |
| PROCEDURE B; |
| |
| GENERIC |
| INPUT : SUBENUM; |
| OUTPUT : IN OUT SUBENUM; |
| PROCEDURE C; |
| |
| GENERIC |
| INPUT : SUBFLT; |
| OUTPUT : IN OUT SUBFLT; |
| PROCEDURE D; |
| |
| GENERIC |
| INPUT : SUBFIX; |
| OUTPUT : IN OUT SUBFIX; |
| PROCEDURE E; |
| |
| GENERIC |
| INPUT : STR; |
| OUTPUT : IN OUT STR; |
| PROCEDURE F; |
| |
| GENERIC |
| INPUT : A1; |
| OUTPUT : IN OUT A1; |
| PROCEDURE G; |
| |
| GENERIC |
| INPUT : SUBREC; |
| OUTPUT : IN OUT SUBREC; |
| PROCEDURE H; |
| |
| GENERIC |
| TYPE GP IS PRIVATE; |
| FUNCTION GENEQUAL (ONE, TWO : GP) RETURN BOOLEAN; |
| |
| FUNCTION GENEQUAL (ONE, TWO : GP) RETURN BOOLEAN IS |
| BEGIN |
| RETURN ONE = TWO; |
| END GENEQUAL; |
| |
| FUNCTION GEN_IDENT (X : GP) RETURN GP IS |
| BEGIN |
| RETURN X; |
| END GEN_IDENT; |
| |
| FUNCTION INT_IDENT IS NEW GEN_IDENT (INT); |
| FUNCTION SUBENUM_IDENT IS NEW GEN_IDENT (SUBENUM); |
| FUNCTION SUBFLT_IDENT IS NEW GEN_IDENT (SUBFLT); |
| FUNCTION SUBFIX_IDENT IS NEW GEN_IDENT (SUBFIX); |
| |
| FUNCTION ENUMEQUAL IS NEW GENEQUAL (SUBENUM); |
| FUNCTION FLTEQUAL IS NEW GENEQUAL (SUBFLT); |
| FUNCTION FIXEQUAL IS NEW GENEQUAL (SUBFIX); |
| FUNCTION STREQUAL IS NEW GENEQUAL (STR); |
| FUNCTION ACCEQUAL IS NEW GENEQUAL (A2); |
| FUNCTION RECEQUAL IS NEW GENEQUAL (REC); |
| |
| PROCEDURE B IS |
| BEGIN |
| OUTPUT := INPUT; |
| FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & |
| "INTEGER TYPE"); |
| IF EQUAL (OUTPUT, OUTPUT) THEN |
| COMMENT ("DON'T OPTIMIZE OUTPUT"); |
| END IF; |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| NULL; |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED"); |
| END B; |
| |
| PROCEDURE C IS |
| BEGIN |
| OUTPUT := INPUT; |
| FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & |
| "ENUMERATION TYPE"); |
| IF ENUMEQUAL (OUTPUT, OUTPUT) THEN |
| COMMENT ("DON'T OPTIMIZE OUTPUT"); |
| END IF; |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| NULL; |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED"); |
| END C; |
| |
| PROCEDURE D IS |
| BEGIN |
| OUTPUT := INPUT; |
| FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & |
| "FLOATING POINT TYPE"); |
| IF FLTEQUAL (OUTPUT, OUTPUT) THEN |
| COMMENT ("DON'T OPTIMIZE OUTPUT"); |
| END IF; |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| NULL; |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED"); |
| END D; |
| |
| PROCEDURE E IS |
| BEGIN |
| OUTPUT := INPUT; |
| FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & |
| "FIXED POINT TYPE"); |
| IF FIXEQUAL (OUTPUT, OUTPUT) THEN |
| COMMENT ("DON'T OPTIMIZE OUTPUT"); |
| END IF; |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| NULL; |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED"); |
| END E; |
| |
| PROCEDURE F IS |
| BEGIN |
| OUTPUT := INPUT; |
| FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & |
| "ARRAY TYPE"); |
| IF STREQUAL (OUTPUT, OUTPUT) THEN |
| COMMENT ("DON'T OPTIMIZE OUTPUT"); |
| END IF; |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| NULL; |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED"); |
| END F; |
| |
| PROCEDURE G IS |
| BEGIN |
| OUTPUT := INPUT; |
| FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & |
| "ACCESS TYPE"); |
| IF ACCEQUAL (OUTPUT, OUTPUT) THEN |
| COMMENT ("DON'T OPTIMIZE OUTPUT"); |
| END IF; |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| NULL; |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED"); |
| END G; |
| |
| PROCEDURE H IS |
| BEGIN |
| OUTPUT := INPUT; |
| FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & |
| "DISCRIMINATED RECORD TYPE"); |
| IF RECEQUAL (OUTPUT, OUTPUT) THEN |
| COMMENT ("DON'T OPTIMIZE OUTPUT"); |
| END IF; |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| NULL; |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED"); |
| END H; |
| |
| PROCEDURE B1 IS NEW B (4, INTVAR); |
| PROCEDURE C1 IS NEW C (FOUR, ENUMVAR); |
| PROCEDURE D1 IS NEW D (-1.0, FLTVAR); |
| PROCEDURE E1 IS NEW E (-1.0, FIXVAR); |
| PROCEDURE F1 IS NEW F ("9876543210", STRVAR); |
| PROCEDURE G1 IS NEW G (A1VAR, A2VAR); |
| PROCEDURE H1 IS NEW H (SUBRECVAR, RECVAR); |
| |
| PROCEDURE B2 IS NEW B (INT_IDENT(INT'FIRST), INTVAR); |
| PROCEDURE C2 IS NEW C (SUBENUM_IDENT(SUBENUM'FIRST), ENUMVAR); |
| PROCEDURE D2 IS NEW D (SUBFLT_IDENT(SUBFLT'FIRST), FLTVAR); |
| PROCEDURE E2 IS NEW E (SUBFIX_IDENT(SUBFIX'FIRST), FIXVAR); |
| |
| BEGIN |
| |
| B1; |
| C1; |
| D1; |
| E1; |
| F1; |
| G1; |
| H1; |
| |
| B2; |
| C2; |
| D2; |
| E2; |
| |
| RESULT; |
| END CC1111A; |
