1-- C35503C.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 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULTS WHEN
27--     THE PREFIX IS AN INTEGER TYPE.
28--     SUBTESTS ARE :
29--         PART (A). TESTS FOR 'IMAGE'.
30--         PART (B). TESTS FOR 'VALUE'.
31
32-- HISTORY:
33--     RJW  03/17/86  CREATED ORIGINAL TEST.
34--     VCL  10/23/87  MODIFIED THIS HEADER, ADDED A CHECK THAT
35--                    CONSTRAINT_ERROR IS RAISED FOR THE ATTRIBUTE
36--                    'VALUE' IF THE FINAL SHARP OR COLON IS MISSING
37--                    FROM A BASED LITERAL.
38
39WITH REPORT; USE REPORT;
40PROCEDURE C35503C IS
41     TYPE NEWINT IS NEW INTEGER;
42     TYPE INT IS RANGE -1000 .. 1000;
43
44     FUNCTION IDENT (X : INT) RETURN INT IS
45     BEGIN
46          IF EQUAL (INT'POS (X), INT'POS(X)) THEN
47               RETURN X;
48          END IF;
49          RETURN INT'FIRST;
50     END IDENT;
51
52BEGIN
53     TEST ("C35503C", "THE ATTIBUTES 'IMAGE' AND 'VALUE' YIELD THE " &
54                      "CORRECT RESULTS WHEN THE PREFIX IS AN " &
55                      "INTEGER TYPE" );
56-- PART (A).
57
58     BEGIN
59          IF INTEGER'IMAGE (-500) /= "-500" THEN
60               FAILED ( "INCORRECT 'IMAGE' OF '-500'" );
61          END IF;
62          IF INTEGER'IMAGE (-500)'FIRST /= 1 THEN
63               FAILED ( "INCORRECT LOWER BOUND FOR '-500'" );
64          END IF;
65
66          IF NEWINT'IMAGE (2 ** 6) /= " 64" THEN
67               FAILED ( "INCORRECT 'IMAGE' OF '2 ** 6'" );
68          END IF;
69          IF NEWINT'IMAGE (2 ** 6)'FIRST /= 1 THEN
70               FAILED ( "INCORRECT LOWER BOUND FOR '2 ** 6'" );
71          END IF;
72
73          IF NATURAL'IMAGE (-1E2) /= "-100" THEN
74               FAILED ( "INCORRECT 'IMAGE' OF '-1E2'" );
75          END IF;
76          IF NATURAL'IMAGE (-1E2)'FIRST /= 1 THEN
77               FAILED ( "INCORRECT LOWER BOUND FOR '-1E2'" );
78          END IF;
79
80          IF NEWINT'IMAGE (3_45) /= " 345" THEN
81               FAILED ( "INCORRECT 'IMAGE' OF '3_45'" );
82          END IF;
83          IF NEWINT'IMAGE (3_45)'FIRST /= 1 THEN
84               FAILED ( "INCORRECT LOWER BOUND FOR '3_45'" );
85          END IF;
86
87          IF INTEGER'IMAGE (-2#1111_1111#) /= "-255" THEN
88               FAILED ( "INCORRECT 'IMAGE' OF '-2#1111_1111#'" );
89          END IF;
90          IF INTEGER'IMAGE (-2#1111_1111#)'FIRST /= 1 THEN
91               FAILED ( "INCORRECT LOWER BOUND FOR '-2#1111_1111#'" );
92          END IF;
93
94          IF NEWINT'IMAGE (16#FF#) /= " 255" THEN
95               FAILED ( "INCORRECT 'IMAGE' OF '16#FF#'" );
96          END IF;
97          IF NEWINT'IMAGE (16#FF#)'FIRST /= 1 THEN
98               FAILED ( "INCORRECT LOWER BOUND FOR '16#FF#'" );
99          END IF;
100
101          IF INTEGER'IMAGE (-016#0FF#) /= "-255" THEN
102               FAILED ( "INCORRECT 'IMAGE' OF '-016#0FF#'" );
103          END IF;
104          IF INTEGER'IMAGE (-016#0FF#)'FIRST /= 1 THEN
105               FAILED ( "INCORRECT LOWER BOUND FOR '-016#0FF#'" );
106          END IF;
107
108          IF NEWINT'IMAGE (2#1110_0000#) /= " 224" THEN
109               FAILED ( "INCORRECT 'IMAGE' OF '2#1110_0000#'" );
110          END IF;
111          IF NEWINT'IMAGE (2#1110_0000#)'FIRST /= 1 THEN
112               FAILED ( "INCORRECT LOWER BOUND FOR '2#1110_0000#'" );
113          END IF;
114
115          IF POSITIVE'IMAGE (-16#E#E1) /= "-224" THEN
116               FAILED ( "INCORRECT 'IMAGE' OF '-16#E#E1'" );
117          END IF;
118          IF POSITIVE'IMAGE (-16#E#E1)'FIRST /= 1 THEN
119               FAILED ( "INCORRECT LOWER BOUND FOR '-16#E#E1'" );
120          END IF;
121
122          IF INT'IMAGE (IDENT(-1000)) /= "-1000" THEN
123               FAILED ( "INCORRECT 'IMAGE' OF '-1000'" );
124          END IF;
125          IF INT'IMAGE (IDENT(-1000))'FIRST /= 1 THEN
126               FAILED ( "INCORRECT LOWER BOUND FOR '-1000'" );
127          END IF;
128
129          IF INT'IMAGE (IDENT(-999)) /= "-999" THEN
130               FAILED ( "INCORRECT 'IMAGE' OF '-999'" );
131          END IF;
132          IF INT'IMAGE (IDENT(-999))'FIRST /= 1 THEN
133               FAILED ( "INCORRECT LOWER BOUND FOR '-999'" );
134          END IF;
135
136          IF INT'IMAGE (IDENT(-10)) /= "-10" THEN
137               FAILED ( "INCORRECT 'IMAGE' OF '-1000'" );
138          END IF;
139          IF INT'IMAGE (IDENT(-10))'FIRST /= 1 THEN
140               FAILED ( "INCORRECT LOWER BOUND FOR '-10'" );
141          END IF;
142
143          IF INT'IMAGE (IDENT(-9)) /= "-9" THEN
144               FAILED ( "INCORRECT 'IMAGE' OF '-9'" );
145          END IF;
146          IF INT'IMAGE (IDENT(-9))'FIRST /= 1 THEN
147               FAILED ( "INCORRECT LOWER BOUND FOR '-9'" );
148          END IF;
149
150          IF INT'IMAGE (IDENT(-1)) /= "-1" THEN
151               FAILED ( "INCORRECT 'IMAGE' OF '-1'" );
152          END IF;
153          IF INT'IMAGE (IDENT(-1))'FIRST /= 1 THEN
154               FAILED ( "INCORRECT LOWER BOUND FOR '-1'" );
155          END IF;
156
157          IF INT'IMAGE (IDENT(0)) /= " 0" THEN
158               FAILED ( "INCORRECT 'IMAGE' OF '0'" );
159          END IF;
160          IF INT'IMAGE (IDENT(0))'FIRST /= 1 THEN
161               FAILED ( "INCORRECT LOWER BOUND FOR '0'" );
162          END IF;
163
164          IF INT'IMAGE (IDENT(1)) /= " 1" THEN
165               FAILED ( "INCORRECT 'IMAGE' OF '1'" );
166          END IF;
167          IF INT'IMAGE (IDENT(1))'FIRST /= 1 THEN
168               FAILED ( "INCORRECT LOWER BOUND FOR '1'" );
169          END IF;
170
171          IF INT'IMAGE (IDENT(9)) /= " 9" THEN
172               FAILED ( "INCORRECT 'IMAGE' OF '9'" );
173          END IF;
174          IF INT'IMAGE (IDENT(9))'FIRST /= 1 THEN
175               FAILED ( "INCORRECT LOWER BOUND FOR '9'" );
176          END IF;
177
178          IF INT'IMAGE (IDENT(10)) /= " 10" THEN
179               FAILED ( "INCORRECT 'IMAGE' OF '10'" );
180          END IF;
181          IF INT'IMAGE (IDENT(10))'FIRST /= 1 THEN
182               FAILED ( "INCORRECT LOWER BOUND FOR '10'" );
183          END IF;
184
185          IF INT'IMAGE (IDENT(999)) /= " 999" THEN
186               FAILED ( "INCORRECT 'IMAGE' OF '999'" );
187          END IF;
188          IF INT'IMAGE (IDENT(999))'FIRST /= 1 THEN
189               FAILED ( "INCORRECT LOWER BOUND FOR '999'" );
190          END IF;
191
192          IF INT'IMAGE (IDENT(1000)) /= " 1000" THEN
193               FAILED ( "INCORRECT 'IMAGE' OF '1000'" );
194          END IF;
195          IF INT'IMAGE (IDENT(1000))'FIRST /= 1 THEN
196               FAILED ( "INCORRECT LOWER BOUND FOR '1000'" );
197          END IF;
198
199     END;
200
201-----------------------------------------------------------------------
202
203-- PART (B).
204
205     BEGIN
206          IF POSITIVE'VALUE (IDENT_STR("-500")) /= -500 THEN
207               FAILED ( "INCORRECT 'VALUE' OF ""-500""" );
208          END IF;
209     EXCEPTION
210          WHEN OTHERS =>
211               FAILED ( "EXCEPTION RAISED - 'VALUE' OF ""-500""" );
212     END;
213
214     BEGIN
215          IF NEWINT'VALUE (" -001E2") /= -100 THEN
216               FAILED ( "INCORRECT 'VALUE' OF "" -001E2""" );
217          END IF;
218     EXCEPTION
219          WHEN OTHERS =>
220               FAILED ( "EXCEPTION RAISED - 'VALUE' OF "" -001E2""" );
221     END;
222
223     BEGIN
224          IF INTEGER'VALUE ("03_45") /= 345 THEN
225               FAILED ( "INCORRECT 'VALUE' OF ""03_45""" );
226          END IF;
227     EXCEPTION
228          WHEN OTHERS =>
229               FAILED ( "EXCEPTION RAISED - 'VALUE' OF ""03_45""" );
230     END;
231
232     BEGIN
233          IF NEWINT'VALUE ("-2#1111_1111#") /= -255 THEN
234               FAILED ( "INCORRECT 'VALUE' OF ""-2#1111_1111#""" );
235          END IF;
236     EXCEPTION
237          WHEN OTHERS =>
238               FAILED ( "EXCEPTION RAISED - 'VALUE' OF "&
239                        """-2#1111_1111#""" );
240     END;
241
242     BEGIN
243          IF INTEGER'VALUE (IDENT_STR("16#FF#")) /= 255 THEN
244               FAILED ( "INCORRECT 'VALUE' OF ""16#FF#""" );
245          END IF;
246     EXCEPTION
247          WHEN OTHERS =>
248               FAILED ( "EXCEPTION RAISED - 'VALUE' OF ""16#FF#""" );
249     END;
250
251     BEGIN
252          IF NATURAL'VALUE (IDENT_STR("-016#0FF#")) /= -255 THEN
253               FAILED ( "INCORRECT 'VALUE' OF ""-016#0FF#""" );
254          END IF;
255     EXCEPTION
256          WHEN OTHERS =>
257               FAILED ( "EXCEPTION RAISED - 'VALUE' OF " &
258                        """-016#0FF#""" );
259     END;
260
261     BEGIN
262          IF INTEGER'VALUE ("2#1110_0000#     ") /= 224 THEN
263               FAILED ( "INCORRECT 'VALUE' OF " &
264                        """2#1110_0000#     """ );
265          END IF;
266     EXCEPTION
267          WHEN OTHERS =>
268               FAILED ( "EXCEPTION RAISED - 'VALUE' OF " &
269                        """2#1110_0000#     """ );
270     END;
271
272     BEGIN
273          IF NEWINT'VALUE ("  -16#E#E1") /= -224 THEN
274               FAILED ( "INCORRECT 'VALUE' OF ""  -16#E#E1""" );
275          END IF;
276     EXCEPTION
277          WHEN OTHERS =>
278               FAILED ( "EXCEPTION RAISED - 'VALUE' OF " &
279                        """  -16#E#E1""" );
280     END;
281
282     BEGIN
283          IF INTEGER'VALUE ("5/0") = 0 THEN
284               FAILED ( "NO EXCEPTION RAISED - ""5/0"" - 1" );
285          ELSE
286               FAILED ( "NO EXCEPTION RAISED - ""5/0"" - 2" );
287          END IF;
288     EXCEPTION
289          WHEN CONSTRAINT_ERROR =>
290               NULL;
291          WHEN OTHERS =>
292               FAILED ( "WRONG EXCEPTION RAISED - ""5/0""" );
293     END;
294
295     DECLARE
296          SUBTYPE SUBINT IS INTEGER RANGE 0 .. 10;
297     BEGIN
298          IF SUBINT'VALUE (IDENT_STR("-500")) /= -500 THEN
299               FAILED ( "INCORRECT VALUE WITH ""-500"" AND SUBINT" );
300          END IF;
301     EXCEPTION
302          WHEN OTHERS =>
303               FAILED ( "EXCEPTION RAISED - SUBINT" );
304     END;
305
306     BEGIN
307          IF INTEGER'VALUE (IDENT_STR("1.0")) = 1 THEN
308               FAILED ( "NO EXCEPTION RAISED - "" 1.0"" - 1" );
309          ELSE
310               FAILED ( "NO EXCEPTION RAISED - ""1.0"" - 2" );
311          END IF;
312     EXCEPTION
313          WHEN CONSTRAINT_ERROR =>
314               NULL;
315          WHEN OTHERS =>
316               FAILED ( "WRONG EXCEPTION RAISED - ""1.0"" " );
317     END;
318
319     BEGIN
320          IF INTEGER'VALUE (IDENT_CHAR(ASCII.HT) & "244") /= 244 THEN
321               FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 1" );
322          ELSE
323               FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 2" );
324          END IF;
325     EXCEPTION
326          WHEN CONSTRAINT_ERROR =>
327               NULL;
328          WHEN OTHERS =>
329               FAILED ( "WRONG EXCEPTION RAISED - LEADING 'HT'" );
330     END;
331
332     BEGIN
333          IF INTEGER'VALUE ("244" & (IDENT_CHAR(ASCII.HT))) /= 244 THEN
334               FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 1" );
335          ELSE
336               FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 2" );
337          END IF;
338     EXCEPTION
339          WHEN CONSTRAINT_ERROR =>
340               NULL;
341          WHEN OTHERS =>
342               FAILED ( "WRONG EXCEPTION RAISED - TRAILING 'HT'" );
343     END;
344
345     BEGIN
346          IF INTEGER'VALUE (IDENT_STR("2__44")) /= 244 THEN
347               FAILED ( "NO EXCEPTION RAISED - CONSECUTIVE '_' - 1" );
348          ELSE
349               FAILED ( "NO EXCEPTION RAISED - CONSECUTIVE '_' - 2" );
350          END IF;
351     EXCEPTION
352          WHEN CONSTRAINT_ERROR =>
353               NULL;
354          WHEN OTHERS =>
355               FAILED ( "WRONG EXCEPTION RAISED " &
356                        "WITH CONSECUTIVE '_'" );
357     END;
358
359     BEGIN
360          IF INTEGER'VALUE (IDENT_STR("_244")) /= 244 THEN
361               FAILED ( "NO EXCEPTION RAISED - LEADING '_' - 1" );
362          ELSE
363               FAILED ( "NO EXCEPTION RAISED - LEADING '_' - 2" );
364          END IF;
365     EXCEPTION
366          WHEN CONSTRAINT_ERROR =>
367               NULL;
368          WHEN OTHERS =>
369               FAILED ( "WRONG EXCEPTION RAISED - LEADING '_'" );
370     END;
371
372     BEGIN
373          IF INTEGER'VALUE (IDENT_STR("244_")) /= 244 THEN
374               FAILED ( "NO EXCEPTION RAISED - TRAILING '_' - 1" );
375          ELSE
376               FAILED ( "NO EXCEPTION RAISED - TRAILING '_' - 2" );
377          END IF;
378     EXCEPTION
379          WHEN CONSTRAINT_ERROR =>
380               NULL;
381          WHEN OTHERS =>
382               FAILED ( "WRONG EXCEPTION RAISED - TRAILING '_'" );
383     END;
384
385     BEGIN
386          IF INTEGER'VALUE (IDENT_STR("244_E1")) /= 2440 THEN
387               FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'E' - 1" );
388          ELSE
389               FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'E' - 2" );
390          END IF;
391     EXCEPTION
392          WHEN CONSTRAINT_ERROR =>
393               NULL;
394          WHEN OTHERS =>
395               FAILED ( "WRONG EXCEPTION RAISED - '_' BEFORE 'E'" );
396     END;
397
398     BEGIN
399          IF INTEGER'VALUE (IDENT_STR("244E_1")) /= 2440 THEN
400               FAILED ( "NO EXCEPTION RAISED - '_' " &
401                        "FOLLOWING 'E' - 1" );
402          ELSE
403               FAILED ( "NO EXCEPTION RAISED - '_' FOLLOWING 'E' - 2" );
404          END IF;
405     EXCEPTION
406          WHEN CONSTRAINT_ERROR =>
407               NULL;
408          WHEN OTHERS =>
409               FAILED ( "WRONG EXCEPTION RAISED " &
410                        "- '_' FOLLOWING 'E'" );
411     END;
412
413     BEGIN
414          IF INTEGER'VALUE (IDENT_STR("244_e1")) /= 2440 THEN
415               FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'e' - 1" );
416          ELSE
417               FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'e' - 2" );
418          END IF;
419     EXCEPTION
420          WHEN CONSTRAINT_ERROR =>
421               NULL;
422          WHEN OTHERS =>
423               FAILED ( "WRONG EXCEPTION RAISED - '_' BEFORE 'e'" );
424     END;
425
426     BEGIN
427          IF INTEGER'VALUE (IDENT_STR("16#_FF#")) /= 255 THEN
428               FAILED ( "NO EXCEPTION RAISED - LEADING '_' IN BASED " &
429                        "LITERAL - 1" );
430          ELSE
431               FAILED ( "NO EXCEPTION RAISED - LEADING '_' IN BASED " &
432                        "LITERAL - 2" );
433          END IF;
434     EXCEPTION
435          WHEN CONSTRAINT_ERROR =>
436               NULL;
437          WHEN OTHERS =>
438               FAILED ( "WRONG EXCEPTION RAISED " &
439                        "- LEADING '_' IN BASED LITERAL" );
440     END;
441
442     BEGIN
443          IF INTEGER'VALUE (IDENT_STR("1E-0")) /= 1 THEN
444               FAILED ( "NO EXCEPTION RAISED - NEGATIVE " &
445                        "EXPONENT - 1" );
446          ELSE
447               FAILED ( "NO EXCEPTION RAISED - NEGATIVE EXPONENT - 2" );
448          END IF;
449     EXCEPTION
450          WHEN CONSTRAINT_ERROR =>
451               NULL;
452          WHEN OTHERS =>
453               FAILED ( "WRONG EXCEPTION RAISED " &
454                        "- NEGATIVE EXPONENT" );
455     END;
456
457     BEGIN
458          IF INTEGER'VALUE (IDENT_STR("244.")) /= 244 THEN
459               FAILED ( "NO EXCEPTION RAISED - TRAILING '.' - 1" );
460          ELSE
461               FAILED ( "NO EXCEPTION RAISED - TRAILING '.' - 2" );
462          END IF;
463     EXCEPTION
464          WHEN CONSTRAINT_ERROR =>
465               NULL;
466          WHEN OTHERS =>
467               FAILED ( "WRONG EXCEPTION RAISED - TRAILING '.'" );
468     END;
469
470     BEGIN
471          IF INTEGER'VALUE (IDENT_STR("8#811#")) /= 0 THEN
472               FAILED ( "NO EXCEPTION RAISED - " &
473                        "DIGITS NOT IN CORRECT RANGE - 1" );
474          ELSE
475               FAILED ( "NO EXCEPTION RAISED - " &
476                        "DIGITS NOT IN CORRECT RANGE - 2" );
477          END IF;
478     EXCEPTION
479          WHEN CONSTRAINT_ERROR =>
480               NULL;
481          WHEN OTHERS =>
482               FAILED ( "WRONG EXCEPTION RAISED - " &
483                        "DIGITS NOT IN CORRECT RANGE" );
484     END;
485
486     BEGIN
487          IF INTEGER'VALUE (IDENT_STR("1#000#")) /= 0 THEN
488               FAILED ( "NO EXCEPTION RAISED - BASE LESS THAN 2 - 1" );
489          ELSE
490               FAILED ( "NO EXCEPTION RAISED - BASE LESS THAN 2 - 2" );
491          END IF;
492     EXCEPTION
493          WHEN CONSTRAINT_ERROR =>
494               NULL;
495          WHEN OTHERS =>
496               FAILED ( "WRONG EXCEPTION RAISED " &
497                        "- BASE LESS THAN 2" );
498     END;
499
500     BEGIN
501          IF INTEGER'VALUE (IDENT_STR("17#0#")) /= 0 THEN
502               FAILED ( "NO EXCEPTION RAISED " &
503                        "- BASE GREATER THAN 16 - 1" );
504          ELSE
505               FAILED ( "NO EXCEPTION RAISED " &
506                        "- BASE GREATER THAN 16 - 2" );
507          END IF;
508     EXCEPTION
509          WHEN CONSTRAINT_ERROR =>
510               NULL;
511          WHEN OTHERS =>
512               FAILED ( "WRONG EXCEPTION RAISED " &
513                        "- BASE GREATER THAN 16" );
514     END;
515
516     BEGIN
517          IF INTEGER'VALUE (IDENT_STR("8#666")) /= 438 THEN
518               FAILED ("NO EXCEPTION RAISED - MISSING FINAL SHARP - 1");
519          ELSE
520               FAILED ("NO EXCEPTION RAISED - MISSING FINAL SHARP - 2");
521          END IF;
522     EXCEPTION
523          WHEN CONSTRAINT_ERROR =>
524               NULL;
525          WHEN OTHERS =>
526               FAILED ("WRONG EXCEPTION RAISED - MISSING FINAL SHARP");
527     END;
528
529     BEGIN
530          IF INTEGER'VALUE (IDENT_STR("16:FF")) /= 255 THEN
531               FAILED ("NO EXCEPTION RAISED - MISSING FINAL COLON - 1");
532          ELSE
533               FAILED ("NO EXCEPTION RAISED - MISSING FINAL COLON - 2");
534          END IF;
535     EXCEPTION
536          WHEN CONSTRAINT_ERROR =>
537               NULL;
538          WHEN OTHERS =>
539               FAILED ("WRONG EXCEPTION RAISED - MISSING FINAL COLON");
540     END;
541
542     RESULT;
543END C35503C;
544