1-- C34018A.ADA
2
3--                             Grant of Unlimited Rights
4--
5--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7--     unlimited rights in the software and documentation contained herein.
8--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
9--     this public release, the Government intends to confer upon all
10--     recipients unlimited rights  equal to those held by the Government.
11--     These rights include rights to use, duplicate, release or disclose the
12--     released technical data and computer software in whole or in part, in
13--     any manner and for any purpose whatsoever, and to have or permit others
14--     to do so.
15--
16--                                    DISCLAIMER
17--
18--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23--     PARTICULAR PURPOSE OF SAID MATERIAL.
24--*
25-- CHECK THAT CALLS OF DERIVED SUBPROGRAMS CHECK CONSTRAINTS OF THE
26-- PARENT SUBPROGRAM, NOT THE CONSTRAINTS OF THE DERIVED SUBTYPE.
27
28-- JBG 11/15/85
29-- JRK 2/12/86   CORRECTED ERROR: RESOLVED AMBIGUOUS CALL G(41) TO
30--               TYPE NEW_INT.
31-- EDS 7/16/98   AVOID OPTIMIZATION
32
33WITH REPORT; USE REPORT;
34PROCEDURE C34018A IS
35
36     PACKAGE P IS
37          TYPE INT IS RANGE 1..100;
38          SUBTYPE INT_50 IS INT RANGE 1..50;
39          SUBTYPE INT_51 IS INT RANGE 51..100;
40
41          FUNCTION "+" (L, R : INT) RETURN INT;
42          FUNCTION G (X : INT_50) RETURN INT_51;
43
44          TYPE STR IS ARRAY (1..10) OF CHARACTER;
45          FUNCTION F (X : STR) RETURN STR;
46     END P;
47
48     USE P;
49
50     TYPE NEW_STR IS NEW P.STR;
51     TYPE NEW_INT IS NEW P.INT RANGE 51..90;
52
53     PACKAGE BODY P IS
54
55          FUNCTION "+" (L, R : INT) RETURN INT IS
56          BEGIN
57               RETURN INT(INTEGER(L) + INTEGER(R));
58          END "+";
59
60          FUNCTION G (X : INT_50) RETURN INT_51 IS
61          BEGIN
62               RETURN X + 10;
63          END G;
64
65          FUNCTION F (X : STR) RETURN STR IS
66          BEGIN
67               RETURN X;
68          END F;
69
70     END P;
71
72BEGIN
73
74     TEST ("C34018A", "CHECK CONSTRAINTS PROCESSED CORRECTLY FOR " &
75                      "CALLS OF DERIVED SUBPROGRAMS");
76
77     DECLARE
78
79          Y : NEW_STR := F("1234567890");    -- UNAMBIGUOUS.
80
81     BEGIN
82          IF Y /= "1234567890" THEN
83               FAILED ("DERIVED F");
84          END IF;
85     END;
86
87     DECLARE
88
89          A : INT := 51;
90          B : NEW_INT := NEW_INT(IDENT_INT(90));
91
92     BEGIN
93
94          BEGIN
95               A := A + 0;
96               FAILED ("NO EXCEPTION - A + 0 = " & INT'IMAGE(A) ); --Use A
97          EXCEPTION
98               WHEN CONSTRAINT_ERROR =>
99                    NULL;
100               WHEN OTHERS =>
101                    FAILED ("UNEXPECTED EXCEPTION - 1");
102          END;
103
104          BEGIN
105               IF B + 2 /= 92 THEN      -- 92 IN INT.
106                    FAILED ("WRONG RESULT - B + 2");
107               END IF;
108          EXCEPTION
109               WHEN CONSTRAINT_ERROR =>
110                    FAILED ("WRONG CONSTRAINT FOR DERIVED ""+""");
111               WHEN OTHERS =>
112                    FAILED ("UNEXPECTED EXCEPTION - 2");
113          END;
114
115          BEGIN
116               IF B + 14 > 90 THEN      -- 104 NOT IN INT.
117                    FAILED ("NO EXCEPTION RAISED FOR DERIVED ""+""");
118               END IF;
119          EXCEPTION
120               WHEN CONSTRAINT_ERROR =>
121                    NULL;
122               WHEN OTHERS =>
123                    FAILED ("UNEXPECTED EXCEPTION - 3");
124          END;
125
126
127          BEGIN
128               IF G(B) > 90 THEN        -- 90 NOT IN INT_50.
129                    FAILED ("NO EXCEPTION RAISED FOR DERIVED G");
130               END IF;
131          EXCEPTION
132               WHEN CONSTRAINT_ERROR =>
133                    NULL;
134               WHEN OTHERS =>
135                    FAILED ("UNEXPECTED EXCEPTION - 4");
136          END;
137
138          BEGIN
139               IF C34018A.G(41) /= 51 THEN  -- 41 CONVERTED TO
140                                            --    NEW_INT'BASE.
141                                            -- 41 IN INT_50.
142                                            -- 51 IN INT_51.
143                    FAILED ("WRONG RESULT - G(41)");
144               END IF;
145          EXCEPTION
146               WHEN CONSTRAINT_ERROR =>
147                    FAILED ("C_E RAISED FOR LITERAL ARGUMENT");
148               WHEN OTHERS =>
149                    FAILED ("UNEXPECTED EXCEPTION - 5");
150          END;
151     END;
152
153     RESULT;
154END C34018A;
155