1-- C34002C.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-- FOR DERIVED INTEGER TYPES:
26
27--   CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE
28--   DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
29--   CONSTRAINED.
30
31--   CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
32--   IMPOSED ON THE DERIVED SUBTYPE.
33
34-- JRK 8/21/86
35
36WITH REPORT; USE REPORT;
37
38PROCEDURE C34002C IS
39
40     TYPE PARENT IS RANGE -100 .. 100;
41
42     TYPE T IS NEW PARENT RANGE
43               PARENT'VAL (IDENT_INT (-30)) ..
44               PARENT'VAL (IDENT_INT ( 30));
45
46     SUBTYPE SUBPARENT IS PARENT RANGE -30 .. 30;
47
48     TYPE S IS NEW SUBPARENT;
49
50     X : T;
51     Y : S;
52
53BEGIN
54     TEST ("C34002C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
55                      "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
56                      "WHEN THE DERIVED TYPE DEFINITION IS " &
57                      "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
58                      "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
59                      "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
60                      "INTEGER TYPES");
61
62     -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
63
64     IF T'POS (T'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST) OR
65        S'POS (S'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST) OR
66        T'POS (T'BASE'LAST)  /= PARENT'POS (PARENT'BASE'LAST)  OR
67        S'POS (S'BASE'LAST)  /= PARENT'POS (PARENT'BASE'LAST)  THEN
68          FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST");
69     END IF;
70
71     IF T'PRED (100) /= 99 OR T'SUCC (99) /= 100 OR
72        S'PRED (100) /= 99 OR S'SUCC (99) /= 100 THEN
73          FAILED ("INCORRECT 'PRED OR 'SUCC");
74     END IF;
75
76     -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
77
78     IF T'FIRST /= -30 OR T'LAST /= 30 OR
79        S'FIRST /= -30 OR S'LAST /= 30 THEN
80          FAILED ("INCORRECT 'FIRST OR 'LAST");
81     END IF;
82
83     BEGIN
84          X := -30;
85          Y := -30;
86          IF PARENT (X) /= PARENT (Y) THEN  -- USE X AND Y.
87               FAILED ("INCORRECT CONVERSION TO PARENT - 1");
88          END IF;
89          X := 30;
90          Y := 30;
91          IF PARENT (X) /= PARENT (Y) THEN  -- USE X AND Y.
92               FAILED ("INCORRECT CONVERSION TO PARENT - 2");
93          END IF;
94     EXCEPTION
95          WHEN OTHERS =>
96               FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
97     END;
98
99     BEGIN
100          X := -31;
101          FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := -31");
102          IF X = -31 THEN  -- USE X.
103               COMMENT ("X ALTERED -- X := -31");
104          END IF;
105     EXCEPTION
106          WHEN CONSTRAINT_ERROR =>
107               NULL;
108          WHEN OTHERS =>
109               FAILED ("WRONG EXCEPTION RAISED -- X := -31");
110     END;
111
112     BEGIN
113          X := 31;
114          FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := 31");
115          IF X = 31 THEN  -- USE X.
116               COMMENT ("X ALTERED -- X := 31");
117          END IF;
118     EXCEPTION
119          WHEN CONSTRAINT_ERROR =>
120               NULL;
121          WHEN OTHERS =>
122               FAILED ("WRONG EXCEPTION RAISED -- X := 31");
123     END;
124
125     BEGIN
126          Y := -31;
127          FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := -31");
128          IF Y = -31 THEN -- USE Y.
129               COMMENT ("Y ALTERED -- Y := -31");
130          END IF;
131     EXCEPTION
132          WHEN CONSTRAINT_ERROR =>
133               NULL;
134          WHEN OTHERS =>
135               FAILED ("WRONG EXCEPTION RAISED -- Y := -31");
136     END;
137
138     BEGIN
139          Y := 31;
140          FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := 31");
141          IF Y = 31 THEN  -- USE Y.
142               COMMENT ("Y ALTERED -- Y := 31");
143          END IF;
144     EXCEPTION
145          WHEN CONSTRAINT_ERROR =>
146               NULL;
147          WHEN OTHERS =>
148               FAILED ("WRONG EXCEPTION RAISED -- Y := 31");
149     END;
150
151     RESULT;
152END C34002C;
153