1-- C48009A.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 ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
26-- IS RAISED IF T IS A SCALAR SUBTYPE AND X IS OUTSIDE THE RANGE OF T,
27-- OR IS WITHIN T'S RANGE AND OUTSIDE OF THE RANGE OF VALUES PERMITTED
28-- FOR OBJECTS DESIGNATED BY VALUES OF THE ALLOCATOR'S BASE TYPE.
29
30-- RM  01/08/80
31-- NL  10/13/81
32-- SPS 10/26/82
33-- JBG 03/02/83
34-- EG  07/05/84
35-- EDS 12/01/97  ADDED IDENT_INT TO MAKE EXPRESSION NON-STATIC.
36
37WITH REPORT;
38
39PROCEDURE  C48009A  IS
40
41     USE REPORT;
42
43BEGIN
44
45     TEST( "C48009A" , "FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK" &
46                       " THAT CONSTRAINT_ERROR IS RAISED WHEN" &
47                       " APPROPRIATE - SCALAR TYPES");
48     DECLARE        -- A1
49
50          SUBTYPE  TA  IS  INTEGER RANGE 1..7;
51          TYPE ATA IS ACCESS TA;
52          VA : ATA;
53
54     BEGIN
55
56          VA  :=  NEW TA'( IDENT_INT(0) );
57          FAILED ("NO EXCEPTION RAISED - 1");
58
59     EXCEPTION
60
61          WHEN  CONSTRAINT_ERROR  =>  NULL;
62          WHEN  OTHERS      =>  FAILED ( "WRONG EXCEPTION RAISED - 1" );
63
64     END;  -- A1
65
66     DECLARE        -- A2
67
68          SUBTYPE T1_7 IS INTEGER RANGE 1..7;
69          TYPE AT2_6 IS ACCESS INTEGER RANGE 2..6;
70          VAT2_6 : AT2_6;
71
72     BEGIN
73
74          BEGIN
75
76               VAT2_6 := NEW T1_7'(1);
77               FAILED ("NO EXCEPTION RAISED - 2");
78
79          EXCEPTION
80
81               WHEN CONSTRAINT_ERROR => NULL;
82               WHEN OTHERS =>
83                    FAILED ("WRONG EXCEPTION RAISED - 2");
84
85          END;
86
87          BEGIN
88
89               VAT2_6 := NEW T1_7'(7);
90               FAILED ("NO EXCEPTION RAISED - 3");
91
92          EXCEPTION
93
94               WHEN CONSTRAINT_ERROR => NULL;
95               WHEN OTHERS =>
96                    FAILED ("WRONG EXCEPTION RAISED - 3");
97
98          END;
99
100     END; -- A2
101
102     RESULT;
103
104END C48009A;
105