← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/tests/test/cg/tcase.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/tests/test/cg/tcase.pp
 
1
{****************************************************************}
 
2
{  CODE GENERATOR TEST PROGRAM                                   }
 
3
{****************************************************************}
 
4
{ NODE TESTED : secondcase()                                     }
 
5
{****************************************************************}
 
6
{ PRE-REQUISITES: secondload()                                   }
 
7
{                 secondassign()                                 }
 
8
{                 secondcalln()                                  }
 
9
{****************************************************************}
 
10
{ DEFINES:                                                       }
 
11
{****************************************************************}
 
12
{ REMARKS: Tests the case statement (except jump table gen.)     }
 
13
{****************************************************************}
 
14
program tcase;
 
15
 
 
16
{$ifdef FPC}
 
17
    {$IFNDEF ver1_0}
 
18
        {$define int64_Test}
 
19
    {$endif}
 
20
{$else}
 
21
    {$define int64_Test}
 
22
{$endif}
 
23
 
 
24
{
 
25
   The value is in LOC_REGISTER (operand to test)
 
26
}
 
27
 
 
28
procedure fail;
 
29
begin
 
30
  WriteLn('Failed!');
 
31
  halt(1);
 
32
end;
 
33
 
 
34
 
 
35
{************************************************************************}
 
36
{                            LINEAR LIST                                 }
 
37
{************************************************************************}
 
38
 
 
39
{   low = high           }
 
40
procedure TestCmpListOneShort;
 
41
 var
 
42
  s: smallint;
 
43
  failed :boolean;
 
44
 begin
 
45
   Write('Linear Comparison list without ranges (smallint)...');
 
46
   s := -12;
 
47
   failed := true;
 
48
   case s of
 
49
   -12 : failed := false;
 
50
   -10 : ;
 
51
   3 : ;
 
52
   else
 
53
   end;
 
54
   if failed then
 
55
     fail
 
56
   else
 
57
     WriteLn('Passed!');
 
58
 end;
 
59
 
 
60
{   low = high           }
 
61
procedure TestCmpListTwoShort;
 
62
 var
 
63
  s: smallint;
 
64
  failed :boolean;
 
65
 begin
 
66
   Write('Linear Comparison list without ranges (smallint)...');
 
67
   s := 30000;
 
68
   failed := true;
 
69
   case s of
 
70
   -12 : ;
 
71
   -10 : ;
 
72
   3 : ;
 
73
   else
 
74
     failed := false;
 
75
   end;
 
76
   if failed then
 
77
     fail
 
78
   else
 
79
     WriteLn('Passed!');
 
80
 end;
 
81
 
 
82
 
 
83
{   low = high           }
 
84
procedure TestCmpListOneWord;
 
85
 var
 
86
  s: word;
 
87
  failed :boolean;
 
88
 begin
 
89
   Write('Linear Comparison list without ranges (word)...');
 
90
   s := 12;
 
91
   failed := true;
 
92
   case s of
 
93
   12 : failed := false;
 
94
   10 : ;
 
95
   3 : ;
 
96
   end;
 
97
   if failed then
 
98
     fail
 
99
   else
 
100
     WriteLn('Passed!');
 
101
 end;
 
102
 
 
103
{   low = high           }
 
104
procedure TestCmpListTwoWord;
 
105
 var
 
106
  s: word;
 
107
  failed :boolean;
 
108
 begin
 
109
   Write('Linear Comparison list without ranges (word)...');
 
110
   s := 30000;
 
111
   failed := true;
 
112
   case s of
 
113
   0 : ;
 
114
   512 : ;
 
115
   3 : ;
 
116
   else
 
117
     failed := false;
 
118
   end;
 
119
   if failed then
 
120
     fail
 
121
   else
 
122
     WriteLn('Passed!');
 
123
 end;
 
124
 
 
125
{$IFDEF INT64_TEST}
 
126
{   low = high           }
 
127
procedure TestCmpListOneInt64;
 
128
 var
 
129
  s: int64;
 
130
  failed :boolean;
 
131
 begin
 
132
   Write('Linear Comparison list without ranges (int64)...');
 
133
   s := 3000000;
 
134
   failed := true;
 
135
   case s of
 
136
   3000000 : failed := false;
 
137
   10 : ;
 
138
   3 : ;
 
139
   end;
 
140
   if failed then
 
141
     fail
 
142
   else
 
143
     WriteLn('Passed!');
 
144
 end;
 
145
 
 
146
{   low = high           }
 
147
procedure TestCmpListTwoInt64;
 
148
 var
 
149
  s: int64;
 
150
  failed :boolean;
 
151
 begin
 
152
   Write('Linear Comparison list without ranges (int64)...');
 
153
   s := 30000;
 
154
   failed := true;
 
155
   case s of
 
156
   0 : ;
 
157
   512 : ;
 
158
   3 : ;
 
159
   else
 
160
     failed := false;
 
161
   end;
 
162
   if failed then
 
163
     fail
 
164
   else
 
165
     WriteLn('Passed!');
 
166
 end;
 
167
 
 
168
 {   low = high           }
 
169
 procedure TestCmpListThreeInt64;
 
170
  var
 
171
   s: int64;
 
172
   l : longint;
 
173
   failed :boolean;
 
174
  begin
 
175
    Write('Linear Comparison list without ranges (int64)...');
 
176
    l:=3000000;
 
177
    s := (int64(l) shl 32);
 
178
    failed := true;
 
179
    case s of
 
180
    (int64(3000000) shl 32) : failed := false;
 
181
    10 : ;
 
182
    3 : ;
 
183
    end;
 
184
    if failed then
 
185
      fail
 
186
    else
 
187
      WriteLn('Passed!');
 
188
  end;
 
189
{$ENDIF}
 
190
 
 
191
 
 
192
procedure TestCmpListRangesOneShort;
 
193
 var
 
194
  s: smallint;
 
195
  failed :boolean;
 
196
 begin
 
197
   Write('Linear Comparison list with ranges (smallint)...');
 
198
   s := -12;
 
199
   failed := true;
 
200
   case s of
 
201
   -12..-8 : failed := false;
 
202
   -7 : ;
 
203
   3 : ;
 
204
   else
 
205
   end;
 
206
   if failed then
 
207
     fail
 
208
   else
 
209
     WriteLn('Passed!');
 
210
 end;
 
211
 
 
212
procedure TestCmpListRangesTwoShort;
 
213
 var
 
214
  s: smallint;
 
215
  failed :boolean;
 
216
 begin
 
217
   Write('Linear Comparison list with ranges (smallint)...');
 
218
   s := 30000;
 
219
   failed := true;
 
220
   case s of
 
221
   -12..-8 : ;
 
222
   -7 : ;
 
223
   3 : ;
 
224
   else
 
225
     failed := false;
 
226
   end;
 
227
   if failed then
 
228
     fail
 
229
   else
 
230
     WriteLn('Passed!');
 
231
 end;
 
232
 
 
233
 
 
234
{   low = high           }
 
235
procedure TestCmpListRangesOneWord;
 
236
 var
 
237
  s: word;
 
238
  failed :boolean;
 
239
 begin
 
240
   Write('Linear Comparison list with ranges (word)...');
 
241
   s := 12;
 
242
   failed := true;
 
243
   case s of
 
244
   12..13 : failed := false;
 
245
   10 : ;
 
246
   3..7 : ;
 
247
   end;
 
248
   if failed then
 
249
     fail
 
250
   else
 
251
     WriteLn('Passed!');
 
252
 end;
 
253
 
 
254
{   low = high           }
 
255
procedure TestCmpListRangesTwoWord;
 
256
 var
 
257
  s: word;
 
258
  failed :boolean;
 
259
 begin
 
260
   Write('Linear Comparison list with ranges (word)...');
 
261
   s := 30000;
 
262
   failed := true;
 
263
   case s of
 
264
   0..2 : ;
 
265
   3..29999 : ;
 
266
   else
 
267
     failed := false;
 
268
   end;
 
269
   if failed then
 
270
     fail
 
271
   else
 
272
     WriteLn('Passed!');
 
273
 end;
 
274
 
 
275
 
 
276
 procedure TestCmpListRangesThreeWord;
 
277
  var
 
278
   s: word;
 
279
   failed :boolean;
 
280
  begin
 
281
    Write('Linear Comparison list with ranges (word)...');
 
282
    s := 3;
 
283
    failed := true;
 
284
    case s of
 
285
    12..13 : ;
 
286
    10 : ;
 
287
    3..7 : failed := false;
 
288
    end;
 
289
    if failed then
 
290
      fail
 
291
    else
 
292
      WriteLn('Passed!');
 
293
  end;
 
294
 
 
295
 
 
296
{$IFDEF INT64_TEST}
 
297
{   low = high           }
 
298
procedure TestCmpListRangesOneInt64;
 
299
 var
 
300
  s: int64;
 
301
  failed :boolean;
 
302
 begin
 
303
   Write('Linear Comparison list with ranges (int64)...');
 
304
   s := 3000000;
 
305
   failed := true;
 
306
   case s of
 
307
   11..3000000 : failed := false;
 
308
   10 : ;
 
309
   0..2 : ;
 
310
   end;
 
311
   if failed then
 
312
     fail
 
313
   else
 
314
     WriteLn('Passed!');
 
315
 end;
 
316
 
 
317
{   low = high           }
 
318
procedure TestCmpListRangesTwoInt64;
 
319
 var
 
320
  s: int64;
 
321
  failed :boolean;
 
322
 begin
 
323
   Write('Linear Comparison list with ranges (int64)...');
 
324
   s := 30000;
 
325
   failed := true;
 
326
   case s of
 
327
   513..10000 : ;
 
328
   512 : ;
 
329
   0..3 : ;
 
330
   else
 
331
     failed := false;
 
332
   end;
 
333
   if failed then
 
334
     fail
 
335
   else
 
336
     WriteLn('Passed!');
 
337
 end;
 
338
{$ENDIF}
 
339
 
 
340
Begin
 
341
  TestCmpListOneShort;
 
342
  TestCmpListTwoShort;
 
343
  TestCmpListOneWord;
 
344
  TestCmpListTwoWord;
 
345
  TestCmpListRangesOneShort;
 
346
  TestCmpListRangesTwoShort;
 
347
  TestCmpListRangesOneWord;
 
348
  TestCmpListRangesTwoWord;
 
349
  TestCmpListRangesThreeWord;
 
350
{$ifdef int64_test}
 
351
  TestCmpListOneInt64;
 
352
  TestCmpListTwoInt64;
 
353
  TestCmpListThreeInt64;
 
354
  TestCmpListRangesOneInt64;
 
355
  TestCmpListRangesTwoInt64;
 
356
{$endif}
 
357
end.