1-- C35505F.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-- OBJECTIVE:
26--     CHECK THAT CONSTRAINT ERROR IS RAISED BY THE ATTRIBUTES
27--     'PRED' AND 'SUCC' WHEN THE PREFIX IS A CHARACTER TYPE
28--     AND THE RESULT IS OUTSIDE OF THE BASE TYPE.
29
30-- HISTORY:
31--     JET 08/18/87  CREATED ORIGINAL TEST.
32
33WITH REPORT; USE REPORT;
34
35PROCEDURE  C35505F  IS
36
37     TYPE CHAR IS ('A', B);
38
39     TYPE NEWCHAR IS NEW CHAR;
40
41     FUNCTION IDENT (CH : CHAR) RETURN CHAR IS
42     BEGIN
43          RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH)));
44     END;
45
46     FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS
47     BEGIN
48          RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH)));
49     END;
50
51BEGIN
52
53     TEST( "C35505F" , "CHECK THAT CONSTRAINT ERROR IS RAISED BY " &
54                       "THE ATTRIBUTES 'PRED' AND 'SUCC' WHEN THE " &
55                       "PREFIX IS A CHARACTER TYPE AND THE RESULT " &
56                       "IS OUTSIDE OF THE BASE TYPE" );
57
58     BEGIN
59          IF CHAR'PRED (IDENT ('A')) = 'A' THEN
60               FAILED ( "NO EXCEPTION RAISED " &
61                        "FOR CHAR'PRED (IDENT ('A')) - 1" );
62          ELSE
63               FAILED ( "NO EXCEPTION RAISED " &
64                        "FOR CHAR'PRED (IDENT ('A')) - 2" );
65          END IF;
66     EXCEPTION
67          WHEN CONSTRAINT_ERROR =>
68               NULL;
69          WHEN OTHERS =>
70               FAILED ( "WRONG EXCEPTION RAISED " &
71                        "FOR CHAR'PRED (IDENT ('A'))" );
72     END;
73
74     BEGIN
75          IF CHAR'SUCC (IDENT (B)) = B THEN
76               FAILED ( "NO EXCEPTION RAISED " &
77                        "FOR CHAR'SUCC (IDENT (B)) - 1" );
78          ELSE
79               FAILED ( "NO EXCEPTION RAISED " &
80                        "FOR CHAR'SUCC (IDENT (B)) - 2" );
81          END IF;
82     EXCEPTION
83          WHEN CONSTRAINT_ERROR =>
84               NULL;
85          WHEN OTHERS =>
86               FAILED ( "WRONG EXCEPTION RAISED " &
87                        "FOR CHAR'SUCC (IDENT (B))" );
88     END;
89
90     BEGIN
91          IF NEWCHAR'PRED (IDENT ('A')) = 'A' THEN
92               FAILED ( "NO EXCEPTION RAISED " &
93                        "FOR NEWCHAR'PRED (IDENT ('A')) - 1" );
94          ELSE
95               FAILED ( "NO EXCEPTION RAISED " &
96                        "FOR NEWCHAR'PRED (IDENT ('A')) - 2" );
97          END IF;
98     EXCEPTION
99          WHEN CONSTRAINT_ERROR =>
100               NULL;
101          WHEN OTHERS =>
102               FAILED ( "WRONG EXCEPTION RAISED " &
103                        "FOR NEWCHAR'PRED (IDENT ('A'))" );
104     END;
105
106     BEGIN
107          IF NEWCHAR'SUCC (IDENT (B)) = 'A' THEN
108               FAILED ( "NO EXCEPTION RAISED " &
109                        "FOR NEWCHAR'SUCC (IDENT (B)) - 1" );
110          ELSE
111               FAILED ( "NO EXCEPTION RAISED " &
112                        "FOR NEWCHAR'SUCC (IDENT (B)) - 2" );
113          END IF;
114     EXCEPTION
115          WHEN CONSTRAINT_ERROR =>
116               NULL;
117          WHEN OTHERS =>
118               FAILED ( "WRONG EXCEPTION RAISED " &
119                        "FOR NEWCHAR'SUCC (IDENT (B))" );
120     END;
121
122     BEGIN
123          IF CHARACTER'PRED (IDENT_CHAR (CHARACTER'BASE'FIRST)) = 'A'
124             THEN
125               FAILED ( "NO EXCEPTION RAISED " &
126                        "FOR CHARACTER'PRED " &
127                        "(IDENT_CHAR (CHARACTER'BASE'FIRST)) - 1" );
128          ELSE
129               FAILED ( "NO EXCEPTION RAISED " &
130                        "FOR CHARACTER'PRED " &
131                        "(IDENT_CHAR (CHARACTER'BASE'FIRST)) - 2" );
132          END IF;
133     EXCEPTION
134          WHEN CONSTRAINT_ERROR =>
135               NULL;
136          WHEN OTHERS =>
137               FAILED ( "WRONG EXCEPTION RAISED " &
138                        "FOR CHARACTER'PRED " &
139                        "(IDENT_CHAR (CHARACTER'BASE'FIRST))" );
140     END;
141
142     BEGIN
143          IF CHARACTER'SUCC (IDENT_CHAR (CHARACTER'BASE'LAST)) = 'Z'
144             THEN
145               FAILED ( "NO EXCEPTION RAISED " &
146                        "FOR CHARACTER'SUCC " &
147                        "(IDENT_CHAR (CHARACTER'BASE'LAST)) - 1" );
148          ELSE
149               FAILED ( "NO EXCEPTION RAISED " &
150                        "FOR CHARACTER'SUCC " &
151                        "(IDENT_CHAR (CHARACTER'BASE'LAST)) - 2" );
152          END IF;
153     EXCEPTION
154          WHEN CONSTRAINT_ERROR =>
155               NULL;
156          WHEN OTHERS =>
157               FAILED ( "WRONG EXCEPTION RAISED " &
158                        "FOR CHARACTER'SUCC " &
159                        "(IDENT_CHAR (CHARACTER'BASE'LAST))" );
160     END;
161
162     RESULT;
163
164END C35505F;
165