3 -- Grant of Unlimited Rights
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
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.
25 -- CHECK THAT PREDEFINED OPERATORS MAY BE PASSED AS ACTUAL
26 -- GENERIC SUBPROGRAM PARAMETERS (CHECKS FOR "=" AND "/=" ARE IN
30 -- JRL 11/15/95 Added unknown discriminant part to all formal
34 WITH REPORT
; USE REPORT
;
38 TYPE T
(<>) IS PRIVATE;
41 WITH FUNCTION F1
(X
: IN T
) RETURN T
;
43 R
: BOOLEAN := F1
(V
) = V1
;
48 IF NOT (IDENT_BOOL
(R
)) THEN
49 FAILED
( "INCORRECT VALUE FOR UNARY OP - " & KIND
);
54 TYPE T
(<>) IS PRIVATE;
57 WITH FUNCTION F1
(P1
: IN T
; P2
: IN T
) RETURN T
;
59 R
: BOOLEAN := V
/= F1
(V1
, V2
);
64 IF IDENT_BOOL
(R
) THEN
65 FAILED
( "INCORRECT VALUE FOR BINARY OP - " & KIND
);
71 TYPE T1
(<>) IS PRIVATE;
72 TYPE T2
(<>) IS PRIVATE;
76 WITH FUNCTION F1
(X
: IN T1
) RETURN T2
;
78 R
: BOOLEAN := F1
(V1
) = V2
;
83 IF NOT (IDENT_BOOL
(R
)) THEN
84 FAILED
( "INCORRECT VALUE FOR OP - " & KIND
);
89 TEST
( "CC3601A", "CHECK THAT PREDEFINED OPERATORS MAY BE " &
90 "PASSED AS ACTUAL GENERIC SUBPROGRAM " &
94 BEGIN -- CHECKS WITH RELATIONAL OPERATORS AND LOGICAL OPERATORS AS
97 FOR I1
IN BOOLEAN LOOP
99 FOR I2
IN BOOLEAN LOOP
100 COMMENT
( "B1 = " & BOOLEAN'IMAGE (I1
) & " AND " &
101 "B2 = " & BOOLEAN'IMAGE (I2
) );
103 B1
: BOOLEAN := IDENT_BOOL
(I1
);
104 B2
: BOOLEAN := IDENT_BOOL
(I2
);
107 NEW GP1
(BOOLEAN, NOT B2
, B2
,
108 """NOT"" - 1", "NOT");
110 NEW GP2
(BOOLEAN, B1
OR B2
, B1
, B2
,
113 NEW GP2
(BOOLEAN, B1
AND B2
, B2
, B1
,
116 NEW GP2
(BOOLEAN, B1
/= B2
, B1
, B2
,
119 NEW GP2
(BOOLEAN, B1
< B2
, B1
, B2
,
122 NEW GP2
(BOOLEAN, B1
<= B2
, B1
, B2
,
125 NEW GP2
(BOOLEAN, B1
> B2
, B1
, B2
,
128 NEW GP2
(BOOLEAN, B1
>= B2
, B1
, B2
,
131 TYPE AB
IS ARRAY (BOOLEAN RANGE <> )
133 AB1
: AB
(BOOLEAN) := (B1
, B2
);
134 AB2
: AB
(BOOLEAN) := (B2
, B1
);
135 T
: AB
(B1
.. B2
) := (B1
.. B2
=> TRUE);
136 F
: AB
(B1
.. B2
) := (B1
.. B2
=> FALSE);
137 VB1
: AB
(B1
.. B1
) := (B1
=> B2
);
138 VB2
: AB
(B2
.. B2
) := (B2
=> B1
);
141 NEW GP1
(AB
, AB1
, NOT AB1
,
142 """NOT"" - 2", "NOT");
145 """NOT"" - 3", "NOT");
147 NEW GP1
(AB
, VB2
, (B2
=> NOT B1
),
148 """NOT"" - 4", "NOT");
150 NEW GP2
(AB
, AB1
AND AB2
, AB1
, AB2
,
159 DECLARE -- CHECKS WITH ADDING AND MULTIPLYING OPERATORS, "**",
162 PACKAGE P1
IS NEW GP1
(INTEGER, -4, -4, """+"" - 1", "+");
164 PACKAGE P2
IS NEW GP1
(FLOAT, 4.0, 4.0, """+"" - 2", "+");
166 PACKAGE P3
IS NEW GP1
(DURATION, -4.0, -4.0, """+"" - 3",
168 PACKAGE P4
IS NEW GP1
(INTEGER, -4, 4, """-"" - 1", "-");
170 PACKAGE P5
IS NEW GP1
(FLOAT, 0.0, 0.0, """-"" - 2", "-");
172 PACKAGE P6
IS NEW GP1
(DURATION, 1.0, -1.0, """-"" - 3",
174 PACKAGE P7
IS NEW GP2
(INTEGER, 6, 1, 5, """+"" - 1", "+");
176 PACKAGE P8
IS NEW GP2
(FLOAT, 6.0, 1.0, 5.0, """+"" - 2",
178 PACKAGE P9
IS NEW GP2
(DURATION, 6.0, 1.0, 5.0, """+"" - 3",
180 PACKAGE P10
IS NEW GP2
(INTEGER, 1, 6, 5, """-"" - 1",
182 PACKAGE P11
IS NEW GP2
(DURATION, 11.0, 6.0,-5.0,
184 PACKAGE P12
IS NEW GP2
(FLOAT, 1.0, 6.0, 5.0, """-"" - 3",
187 SUBTYPE SUBINT
IS INTEGER RANGE 0 .. 2;
188 TYPE STR
IS ARRAY (SUBINT
RANGE <>) OF CHARACTER;
189 VSTR
: STR
(0 .. 1) := "AB";
191 PACKAGE P13
IS NEW GP2
(STR
, VSTR
(0 .. 0) &
194 VSTR
(1 .. 1), """&"" - 1", "&");
196 PACKAGE P14
IS NEW GP2
(STR
, VSTR
(1 .. 1) &
199 VSTR
(0 .. 0), """&"" - 2", "&");
201 PACKAGE P15
IS NEW GP2
(INTEGER, 0, -1, 0, """*"" - 1", "*");
203 PACKAGE P16
IS NEW GP2
(FLOAT, 6.0, 3.0, 2.0, """*"" - 2",
205 PACKAGE P17
IS NEW GP2
(INTEGER, 0, 0, 6, """/"" - 1", "/");
207 PACKAGE P18
IS NEW GP2
(FLOAT, 3.0, 6.0, 2.0, """/"" - 2",
209 PACKAGE P19
IS NEW GP2
(INTEGER, -1, -11, 5, "REM", "REM");
211 PACKAGE P20
IS NEW GP2
(INTEGER, 4, -11, 5, "MOD", "MOD");
213 PACKAGE P21
IS NEW GP1
(INTEGER, 5, 5, """ABS"" - 1", "ABS");
215 PACKAGE P22
IS NEW GP1
(FLOAT, -5.0, 5.0, """ABS"" - 2",
218 PACKAGE P23
IS NEW GP1
(DURATION, 0.0, 0.0, """ABS"" - 3",
221 PACKAGE P24
IS NEW GP2
(INTEGER, 9, 3, 2, """**"" - 1",
224 PACKAGE P25
IS NEW GP2
(INTEGER, 1, 5, 0, """**"" - 2",
231 DECLARE -- CHECKS WITH ATTRIBUTES.
233 TYPE WEEKDAY
IS (MON
, TUES
, WED
, THUR
, FRI
);
235 PACKAGE P1
IS NEW GP1
(WEEKDAY
, TUES
, WED
, "WEEKDAY'SUCC",
238 PACKAGE P2
IS NEW GP1
(WEEKDAY
, TUES
, MON
, "WEEKDAY'PRED",
241 PACKAGE P3
IS NEW GP3
(WEEKDAY
, STRING, THUR
, "THUR",
242 "WEEKDAY'IMAGE", WEEKDAY
'IMAGE);
244 PACKAGE P4
IS NEW GP3
(STRING, WEEKDAY
, "FRI", FRI
,
245 "WEEKDAY'VALUE", WEEKDAY
'VALUE);