1-- CE3908A.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 GET FOR ENUMERATION TYPES CAN OPERATE ON STRINGS.
27--     CHECK THAT IT RAISES END_ERROR WHEN THE STRING IS NULL OR
28--     EMPTY.  CHECK THAT LAST CONTAINS THE INDEX VALUE OF THE LAST
29--     CHARACTER READ FROM THE STRING.
30
31-- HISTORY:
32--     SPS 10/11/82
33--     VKG 01/06/83
34--     JBG 02/22/84  CHANGED TO .ADA TEST
35--     DWC 09/18/87  ADDED CASES WHICH CONTAIN TABS WITH AND WITHOUT
36--                   ENUMERATION LITERALS.
37
38WITH REPORT;
39USE REPORT;
40WITH TEXT_IO;
41USE TEXT_IO;
42
43PROCEDURE CE3908A IS
44BEGIN
45
46     TEST ("CE3908A", "CHECK THAT GET FOR ENUMERATION TYPES CAN " &
47                      "OPERATE ON STRINGS.  CHECK THAT IT RAISES " &
48                      "END_ERROR WHEN THE STRING IS NULL OR EMPTY.  " &
49                      "CHECK THAT LAST CONTAINS THE INDEX VALUE OF " &
50                      "THE LAST CHARACTER READ FROM THE STRING");
51
52     DECLARE
53          TYPE FRUIT IS (APPLE, PEAR, ORANGE, STRAWBERRY);
54          DESSERT : FRUIT;
55          PACKAGE FRUIT_IO IS NEW ENUMERATION_IO (FRUIT);
56          USE FRUIT_IO;
57          L : POSITIVE;
58     BEGIN
59          GET ("APPLE  ", DESSERT, L);
60          IF DESSERT /= APPLE THEN
61               FAILED ("ENUMERATION VALUE FROM STRING INCORRECT - 1");
62          END IF;
63
64          IF L /= IDENT_INT (5) THEN
65               FAILED ("LAST CONTAINS INCORRECT VALUE AFTER GET - 1");
66          END IF;
67
68          GET ("APPLE", DESSERT, L);
69          IF DESSERT /= APPLE THEN
70               FAILED ("ENUMERATION VALUE FROM STRING INCORRECT - 2");
71          END IF;
72
73          IF L /= IDENT_INT (5) THEN
74               FAILED ("LAST CONTAINS INCORRECT VALUE AFTER GET - 2");
75          END IF;
76
77          BEGIN
78               GET (ASCII.HT & "APPLE", DESSERT, L);
79               IF DESSERT /= APPLE THEN
80                    FAILED ("ENUMERATION VALUE FROM STRING " &
81                            "INCORRECT - 3");
82               END IF;
83               IF L /= IDENT_INT(6) THEN
84                    FAILED ("LAST CONTAINS INCORRECT VALUE AFTER " &
85                            "GET - 3");
86               END IF;
87          EXCEPTION
88               WHEN END_ERROR =>
89                    FAILED ("GET DID NOT SKIP LEADING TABS");
90               WHEN OTHERS =>
91                    FAILED ("WRONG EXCEPTION RAISED - 3");
92          END;
93
94-- NULL STRING LITERAL.
95
96          BEGIN
97               GET ("", DESSERT, L);
98               FAILED ("END_ERROR NOT RAISED - 4");
99          EXCEPTION
100               WHEN END_ERROR =>
101                    IF L /= IDENT_INT(6) THEN
102                         FAILED ("LAST CONTAINS INCORRECT VALUE " &
103                                 "AFTER GET - 4");
104                    END IF;
105               WHEN OTHERS =>
106                    FAILED ("WRONG EXCEPTION RAISED - 4");
107          END;
108
109          BEGIN
110               GET (ASCII.HT & "", DESSERT, L);
111               FAILED ("END_ERROR NOT RAISED - 5");
112          EXCEPTION
113               WHEN END_ERROR =>
114                    IF L /= IDENT_INT(6) THEN
115                         FAILED ("LAST CONTAINS INCORRECT VALUE " &
116                                 "AFTER GET - 5");
117                    END IF;
118               WHEN OTHERS =>
119                    FAILED ("WRONG EXCEPTION RAISED - 5");
120          END;
121
122-- STRING LITERAL WITH BLANKS.
123
124          BEGIN
125               GET("     ", DESSERT, L);
126               FAILED ("END ERROR NOT RAISED - 6");
127          EXCEPTION
128               WHEN END_ERROR =>
129                    IF L /= IDENT_INT(6) THEN
130                         FAILED ("LAST CONTAINS INCORRECT VALUE " &
131                                 "AFTER GET - 6");
132                    END IF;
133               WHEN OTHERS =>
134                    FAILED ("WRONG EXCEPTION RAISED - 6");
135          END;
136
137     END;
138
139     RESULT;
140END CE3908A;
141