1-- C48005A.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 AN ALLOCATOR OF THE FORM "NEW T X" ALLOCATES A NEW OBJECT
26-- EACH TIME IT IS EXECUTED AND THAT IF T IS AN UNCONSTRAINED RECORD,
27-- PRIVATE, OR LIMITED TYPE, THE ALLOCATED OBJECT HAS THE DISCRIMINANT
28-- VALUES SPECIFIED BY X.
29
30-- EG  08/08/84
31
32WITH REPORT;
33
34PROCEDURE C48005A IS
35
36     USE REPORT;
37
38BEGIN
39
40     TEST("C48005A","CHECK THAT THE FORM 'NEW T X' ALLOCATES A " &
41                    "NEW OBJECT AND THAT IF T IS AN UNCONSTRAINED " &
42                    "RECORD, PRIVATE, OR LIMITED TYPE, THE " &
43                    "ALLOCATED OBJECT HAS THE DISCRIMINANT " &
44                    "VALUES SPECIFIED BY X");
45
46     DECLARE
47
48          TYPE UR1(A : INTEGER) IS
49               RECORD
50                    B : INTEGER := 7;
51                    C : INTEGER := 4;
52               END RECORD;
53          TYPE UR2(A : INTEGER) IS
54               RECORD
55                    CASE A IS
56                         WHEN 1 =>
57                              A1 : INTEGER := 4;
58                         WHEN 2 =>
59                              A2 : INTEGER := 5;
60                         WHEN OTHERS =>
61                              NULL;
62                    END CASE;
63               END RECORD;
64
65          TYPE A_UR1 IS ACCESS UR1;
66          TYPE A_UR2 IS ACCESS UR2;
67
68          V1AUR1 : A_UR1;
69          V1AUR2, V2AUR2 : A_UR2;
70
71          TYPE REC (A : INTEGER) IS
72               RECORD
73                    B : INTEGER;
74               END RECORD;
75
76          TYPE A_REC IS ACCESS REC;
77
78          V_A_REC : A_REC;
79
80          TYPE ARR IS ARRAY(1 .. 1) OF INTEGER;
81
82          TYPE RECVAL IS
83               RECORD
84                    A : INTEGER;
85                    B : ARR;
86               END RECORD;
87
88          FUNCTION FUN (A : INTEGER) RETURN INTEGER IS
89          BEGIN
90               RETURN IDENT_INT(A);
91          END FUN;
92          FUNCTION FUN (A : INTEGER) RETURN RECVAL IS
93          BEGIN
94               FAILED ("WRONG OVERLOADED FUNCTION CALLED");
95               RETURN (1, (1 => 2));
96          END FUN;
97
98     BEGIN
99
100          V1AUR1 := NEW UR1(3);
101          IF ( V1AUR1.A /= 3 OR V1AUR1.B /= 7 OR
102               V1AUR1.C /= IDENT_INT(4) ) THEN
103               FAILED("WRONG VALUES - V1UAR1");
104          END IF;
105
106          V1AUR2 := NEW UR2(IDENT_INT(2));
107          IF ( V1AUR2.A /= 2 OR V1AUR2.A2 /= IDENT_INT(5) ) THEN
108               FAILED("WRONG VALUES - V1AUR2");
109          END IF;
110
111          V2AUR2 := NEW UR2(IDENT_INT(3));
112          IF ( V2AUR2.A /= IDENT_INT(3) ) THEN
113               FAILED("WRONG VALUES - V2AUR2");
114          END IF;
115
116          V_A_REC := NEW REC(FUN(2));
117     END;
118
119     RESULT;
120
121END C48005A;
122