Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c332001.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 -- C332001.A
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 --
26 -- OBJECTIVE:
27 -- Check that the static expression given for a number declaration may be
28 -- of any numeric type. Check that the type of a named number is
29 -- universal_integer or universal_real regardless of the type of the
30 -- static expression that provides its value.
31 --
32 -- TEST DESCRIPTION:
33 -- This test defines a large cross section of mixed type named numbers.
34 -- Well, obviously the named numbers don't have types (other than
35 -- universal_integer and universal_real) associated with them.
36 -- This test uses typed static values in the definition of several named
37 -- numbers, and then mixes the named numbers to ensure that their typed
38 -- origins do not interfere with the use of their values.
39 --
40 --
41 -- CHANGE HISTORY:
42 -- 10 OCT 95 SAIC Initial version
43 -- 11 APR 96 SAIC Fixed a few arithmetic errors for 2.1
44 -- 24 NOV 98 RLB Removed decimal types to insure that this
45 -- test is applicable to all implementations.
46 --
47 --!
48
49 ----------------------------------------------------------------- C332001_0
50
51 package C332001_0 is
52
53 type Enumeration_Type is ( Ah, Gnome, Er, Ay, Shun );
54
55 type Integer_Type is range 0..1023;
56
57 type Modular_Type is mod 256;
58
59 type Floating_Type is digits 4;
60
61 type Fixed_Type is delta 0.125 range -10.0 .. 10.0;
62
63 type Mod_Array is array(Modular_Type) of Floating_Type;
64
65 type Int_Array is array(Integer_Type) of Fixed_Type;
66
67 type Record_Type is record
68 Pinkie : Integer_Type;
69 Ring : Modular_Type;
70 Middle : Floating_Type;
71 Index : Fixed_Type;
72 end record;
73
74 Mod_Array_Object : Mod_Array;
75 Int_Array_Object : Int_Array;
76
77 Record_Object : Record_Type;
78
79 -- numeric_literals
80
81 Nothing_New_Integer : constant := 1;
82 Nothing_New_Real : constant := 1.0;
83
84 -- static constants
85
86 Integ : constant Integer_Type := 2;
87 Modul : constant Modular_Type := 2;
88 Float : constant Floating_Type := 2.0; -- bad practice, good test
89 Fixed : constant Fixed_Type := 2.0;
90
91 Named_Integer : constant := Integ; -- 2
92 Named_Modular : constant := Modul; -- 2
93 Named_Float : constant := Float; -- 2.0
94 Named_Fixed : constant := Fixed; -- 2.0
95
96 -- function calls
97 -- parenthetical expressions
98
99 Fn_Integer : constant := Integer_Type'Min(Integ * 2, 8); -- 4
100 Fn_Modular : constant := Modular_Type'Max(Modul + 2, Modular_Type'First);--4
101 Fn_Float : constant := (Float ** 2); -- 4.0
102 Fn_Fixed : constant := - Fixed; -- -2.0
103 -- attributes
104
105 ITF : constant := Integer_Type'First; -- 0
106 MTL : constant := Modular_Type'Last; -- 255
107 MTM : constant := Modular_Type'Modulus; -- 256
108 ENP : constant := Enumeration_Type'Pos(Ay); -- 3
109 MTP : constant := Modular_Type'Pred(Modul); -- 1
110 FTS : constant := Fixed_Type'Size; -- # impdef
111 ITS : constant := Integer_Type'Succ(Integ); -- 3
112
113 -- array attributes 'First, 'Last, 'Length
114
115 MAFirst : constant := Mod_Array_Object'First; -- 0
116 IALast : constant := Int_Array_Object'Last; -- 1023
117 MAL : constant := Mod_Array_Object'Length; -- 255
118 IAL : constant := Int_Array_Object'Length; -- 1024
119
120 -- type conversions
121 --
122 -- F\T Int Mod Flt Fix
123 -- Int . X O X
124 -- Mod O . X O
125 -- Flt X O . X
126 -- Fix O X O .
127
128 Int2Mod : constant := Modular_Type (Integ); -- 2
129 Int2Fix : constant := Fixed_Type (Integ); -- 2.0
130 Mod2Flt : constant := Floating_Type (Modul); -- 2.0
131 Flt2Int : constant := Integer_Type(Float); -- 2
132 Flt2Fix : constant := Fixed_Type (Float); -- 2.0
133 Fix2Mod : constant := Modular_Type (Fixed); -- 2
134
135 procedure Check_Values;
136
137 -- TRANSITION CHECKS
138 --
139 -- The following were illegal in Ada83; they are now legal in Ada95
140 --
141
142 Int_Base_First : constant := Integer'Base'First; -- # impdef
143 Int_First : constant := Integer'First; -- # impdef
144 Int_Last : constant := Integer'Last; -- # impdef
145 Int_Val : constant := Integer'Val(17); -- 17
146
147 -- END OF TRANSITION CHECKS
148
149 end C332001_0;
150
151 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
152
153 with Report;
154 package body C332001_0 is
155
156 procedure Assert( Truth : Boolean; Message: String ) is
157 begin
158 if not Truth then
159 Report.Failed("Assertion " & Message & " not true" );
160 end if;
161 end Assert;
162
163 procedure Check_Values is
164 begin
165
166 Assert( Nothing_New_Integer * Named_Integer = Named_Modular,
167 "Nothing_New_Integer * Named_Integer = Named_Modular" ); -- 1*2 = 2
168 Assert( Nothing_New_Real * Named_Float = Named_Fixed,
169 "Nothing_New_Real * Named_Float = Named_Fixed" );-- 1.0*2.0 = 2.0
170
171 Assert( Fn_Integer = Int2Mod + Flt2Int,
172 "Fn_Integer = Int2Mod + Flt2Int" ); -- 4 = 2+2
173 Assert( Fn_Modular = Flt2Int * 2,
174 "Fn_Modular = Flt2Int * 2" ); -- 4 = 2*2
175 Assert( Fn_Float = Mod2Flt ** Fix2Mod,
176 "Fn_Float = Mod2Flt ** Fix2Mod" ); -- 4.0 = 2.0**2
177 Assert( Fn_Fixed = (- Mod2Flt),
178 "Fn_Fixed = (- Mod2Flt)" ); -- -2.0 = (-2.0)
179
180 Assert( ITF = Modular_Type'First,
181 "ITF = Modular_Type'First" ); -- 0 = 0
182 Assert( MTL < Integer_Type'Last,
183 "MTL < Integer_Type'Last" ); -- 255 < 1023
184 Assert( MTM < Integer_Type'Last,
185 "MTM < Integer_Type'Last" ); -- 256 < 1023
186 Assert( ENP > MTP,
187 "ENP > MTP" ); -- 3 > 1
188 Assert( (FTS < MTL) or (FTS >= MTL), -- given FTS is impdef...
189 "(FTS < MTL) or (FTS >= MTL)" ); -- True
190 Assert( FTS > ITS,
191 "FTS > ITS" ); -- impdef > 3
192
193 Assert( MAFirst = Int_Array_Object'First,
194 "MAFirst = Int_Array_Object'First" ); -- 0 = 0
195 Assert( IALast > MAFirst,
196 "IALast > MAFirst" ); -- 1023 > 0
197 Assert( MAL < IAL,
198 "MAL < IAL" ); -- 255 < 1024
199
200 Assert( Mod2Flt = Flt2Fix,
201 "Mod2Flt = Flt2Fix" ); -- 2.0 = 2.0
202
203 end Check_Values;
204
205 end C332001_0;
206
207 ------------------------------------------------------------------- C332001
208
209 with Report;
210 with C332001_0;
211 procedure C332001 is
212
213 begin -- Main test procedure.
214
215 Report.Test ("C332001", "Check that the static expression given for a " &
216 "number declaration may be of any numeric type. " &
217 "Check that the type of the named number is " &
218 "universal_integer of universal_real regardless " &
219 "of the type of the static expression that " &
220 "provides its value" );
221
222 C332001_0.Check_Values;
223
224 Report.Result;
225
226 end C332001;