1-- C35508L.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 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE
26-- PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS A
27-- BOOLEAN TYPE.
28
29-- RJW 3/24/86
30
31WITH REPORT; USE REPORT;
32
33PROCEDURE C35508L IS
34
35BEGIN
36     TEST ("C35508L", "CHECK THAT 'POS' AND 'VAL' YIELD THE " &
37                      "CORRECT RESULTS WHEN THE PREFIX IS A " &
38                      "FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER " &
39                      "IS A BOOLEAN TYPE" );
40
41     DECLARE
42          TYPE NEWBOOL IS NEW BOOLEAN;
43
44          GENERIC
45               TYPE BOOL IS (<>);
46          PROCEDURE P (STR : STRING; B : BOOL; I : INTEGER);
47
48          PROCEDURE P (STR : STRING; B : BOOL; I : INTEGER) IS
49               SUBTYPE SBOOL IS BOOL
50               RANGE BOOL'VAL (IDENT_INT(0)) .. BOOL'VAL (IDENT_INT(0));
51          BEGIN
52               IF BOOL'POS (B) /= I THEN
53                    FAILED ( "WRONG " & STR & "'POS FOR " &
54                              BOOL'IMAGE (B) & " - 1" );
55               END IF;
56               IF BOOL'VAL (I) /= B THEN
57                    FAILED ( "WRONG " & STR & "'VAL FOR " &
58                              INTEGER'IMAGE (I) & " - 1" );
59               END IF;
60
61               IF SBOOL'POS (B) /= I THEN
62                    FAILED ( "WRONG " & STR & "'POS FOR " &
63                              BOOL'IMAGE (B) & " - 2" );
64               END IF;
65
66               IF SBOOL'VAL (I) /= B THEN
67                    FAILED ( "WRONG " & STR & "'VAL FOR " &
68                              INTEGER'IMAGE (I) & " - 2" );
69               END IF;
70          END P;
71
72          GENERIC
73               TYPE BOOL IS (<>);
74          PROCEDURE Q (STR : STRING; B : BOOL; I : INTEGER);
75
76          PROCEDURE Q (STR : STRING; B : BOOL; I : INTEGER) IS
77               SUBTYPE SBOOL IS BOOL
78               RANGE BOOL'VAL (IDENT_INT(0)) .. BOOL'VAL (IDENT_INT(0));
79          BEGIN
80               BEGIN
81                    IF BOOL'VAL (I) = B THEN
82                         FAILED (STR & "'VAL OF " & INTEGER'IMAGE (I) &
83                                       " = " & BOOL'IMAGE (B));
84                    END IF;
85                    FAILED ( "NO EXCEPTION RAISED FOR " & STR &
86                             "'VAL OF " & INTEGER'IMAGE (I) );
87               EXCEPTION
88                    WHEN CONSTRAINT_ERROR =>
89                         NULL;
90                    WHEN OTHERS =>
91                         FAILED ( "WRONG EXCEPTION RAISED FOR " & STR &
92                                  "'VAL " & "OF " &
93                                   INTEGER'IMAGE (I) );
94               END;
95
96               BEGIN
97                    IF SBOOL'VAL (I) = B THEN
98                         FAILED (STR & " SBOOL'VAL OF " &
99                                 INTEGER'IMAGE(I) & " = " &
100                                 BOOL'IMAGE (B) );
101                         END IF;
102                         FAILED( "NO EXCEPTION RAISED FOR VAL OF " &
103                                  INTEGER'IMAGE (I)  &
104                                 "WITH SBOOL OF " & STR);
105               EXCEPTION
106                    WHEN CONSTRAINT_ERROR =>
107                         NULL;
108                    WHEN OTHERS =>
109                         FAILED ( "WRONG EXCEPTION RAISED FOR " & STR &
110                                  "'VAL " & "OF " &
111                                   INTEGER'IMAGE (I) &
112                                  "WITH SBOOL " );
113               END;
114          END Q;
115
116          PROCEDURE NP1 IS NEW P ( BOOL => BOOLEAN );
117          PROCEDURE NP2 IS NEW P ( BOOL => NEWBOOL );
118          PROCEDURE NQ1 IS NEW Q ( BOOL => BOOLEAN );
119          PROCEDURE NQ2 IS NEW Q ( BOOL => NEWBOOL );
120     BEGIN
121          NP1 ( "BOOLEAN", IDENT_BOOL(FALSE) , IDENT_INT(0) );
122          NP1 ( "BOOLEAN", IDENT_BOOL(TRUE) , IDENT_INT(1) );
123          NP2 ( "NEWBOOL", FALSE , 0 );
124          NP2 ( "NEWBOOL", TRUE , 1 );
125          NQ1 ( "BOOLEAN", IDENT_BOOL(FALSE) , IDENT_INT(-1) );
126          NQ1 ( "BOOLEAN", IDENT_BOOL(TRUE) , IDENT_INT(2) );
127          NQ2 ( "NEWBOOL", FALSE , -1 );
128          NQ2 ( "NEWBOOL", TRUE , 2 );
129     END;
130
131     RESULT;
132END C35508L;
133