← Back to branch summary

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

« back to all changes in this revision

Viewing changes to fpcsrc/tests/test/cg/tcalcst1.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/tcalcst1.pp
 
1
{****************************************************************}
 
2
{  CODE GENERATOR TEST PROGRAM                                   }
 
3
{  By Carl Eric Codere                                           }
 
4
{****************************************************************}
 
5
{ NODE TESTED : secondcallparan()                                }
 
6
{****************************************************************}
 
7
{ PRE-REQUISITES: secondload()                                   }
 
8
{                 secondassign()                                 }
 
9
{                 secondtypeconv()                               }
 
10
{                 secondtryexcept()                              }
 
11
{                 secondcalln()                                  }
 
12
{                 secondadd()                                    }
 
13
{****************************************************************}
 
14
{ DEFINES:                                                       }
 
15
{            FPC     = Target is FreePascal compiler             }
 
16
{****************************************************************}
 
17
{ REMARKS: This tests a subset of the secondcalln() node         }
 
18
{          (const parameters)                                    }
 
19
{****************************************************************}
 
20
program tcalcst1;
 
21
{$ifdef fpc}
 
22
{$mode objfpc}
 
23
{$INLINE ON}
 
24
{$endif}
 
25
{$R+}
 
26
 
 
27
{$ifdef VER70}
 
28
  {$define tp}
 
29
{$endif}
 
30
 
 
31
 { REAL should map to single or double }
 
32
 { so it is not checked, since single  }
 
33
 { double nodes are checked.           }
 
34
 
 
35
 { assumes that enumdef is the same as orddef (same storage format) }
 
36
 
 
37
 const
 
38
{ should be defined depending on CPU target }
 
39
{$ifdef fpc}
 
40
  {$ifdef cpu68k}
 
41
    BIG_INDEX = 8000;
 
42
    SMALL_INDEX  = 13;
 
43
  {$else}
 
44
    BIG_INDEX = 33000;
 
45
    SMALL_INDEX = 13;     { value should not be aligned! }
 
46
  {$endif}
 
47
{$else}
 
48
  BIG_INDEX = 33000;
 
49
  SMALL_INDEX = 13;     { value should not be aligned! }
 
50
{$endif}
 
51
  RESULT_U8BIT = $55;
 
52
  RESULT_U16BIT = $500F;
 
53
  RESULT_S32BIT = $500F0000;
 
54
  RESULT_S64BIT = $500F0000;
 
55
  RESULT_S32REAL = 1777.12;
 
56
  RESULT_S64REAL = 3444.24;
 
57
  RESULT_BOOL8BIT = 1;
 
58
  RESULT_BOOL16BIT = 1;
 
59
  RESULT_BOOL32BIT = 1;
 
60
  RESULT_PCHAR = 'Hello world';
 
61
  RESULT_BIGSTRING = 'Hello world';
 
62
  RESULT_SMALLSTRING = 'H';
 
63
  RESULT_CHAR = 'I';
 
64
  RESULT_BOOLEAN = TRUE;
 
65
 
 
66
type
 
67
{$ifndef tp}
 
68
  tclass1 = class
 
69
  end;
 
70
{$else}
 
71
  shortstring = string;
 
72
{$endif}
 
73
 
 
74
  tprocedure = procedure;
 
75
 
 
76
  tsmallrecord =
 
77
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
 
78
  packed
 
79
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
 
80
  record
 
81
    b: byte;
 
82
    w: word;
 
83
  end;
 
84
 
 
85
  tlargerecord = packed record
 
86
    b: array[1..BIG_INDEX] of byte;
 
87
  end;
 
88
 
 
89
  tsmallarray = packed array[1..SMALL_INDEX] of byte;
 
90
 
 
91
  tsmallsetenum =
 
92
  (A_A,A_B,A_C,A_D);
 
93
 
 
94
  tsmallset = set of tsmallsetenum;
 
95
  tlargeset = set of char;
 
96
 
 
97
  tsmallstring = string[2];
 
98
 
 
99
 
 
100
 
 
101
 
 
102
 
 
103
var
 
104
 global_u8bit : byte;
 
105
 global_u16bit : word;
 
106
 global_s32bit : longint;
 
107
 global_s32real : single;
 
108
 global_s64real : double;
 
109
 global_ptr : pchar;
 
110
 global_proc : tprocedure;
 
111
 global_bigstring : shortstring;
 
112
 global_boolean : boolean;
 
113
 global_char : char;
 
114
 value_u8bit : byte;
 
115
 value_u16bit : word;
 
116
 value_s32bit : longint;
 
117
{$ifndef tp}
 
118
 global_class : tclass1;
 
119
 global_s64bit : int64;
 
120
 value_s64bit : int64;
 
121
 value_class : tclass1;
 
122
{$endif}
 
123
 value_s32real : single;
 
124
 value_s64real  : double;
 
125
 value_proc : tprocedure;
 
126
 value_ptr : pchar;
 
127
 value_smallrec : tsmallrecord;
 
128
 value_largerec : tlargerecord;
 
129
 value_smallset : tsmallset;
 
130
 value_smallstring : tsmallstring;
 
131
 value_bigstring   : shortstring;
 
132
 value_largeset : tlargeset;
 
133
 value_smallarray : tsmallarray;
 
134
 value_boolean : boolean;
 
135
 value_char : char;
 
136
 
 
137
    procedure fail;
 
138
    begin
 
139
      WriteLn('Failure.');
 
140
      halt(1);
 
141
    end;
 
142
 
 
143
 
 
144
    procedure clear_globals;
 
145
     begin
 
146
      global_u8bit := 0;
 
147
      global_u16bit := 0;
 
148
      global_s32bit := 0;
 
149
      global_s32real := 0.0;
 
150
      global_s64real := 0.0;
 
151
      global_ptr := nil;
 
152
      global_proc := nil;
 
153
      global_bigstring := '';
 
154
      global_boolean := false;
 
155
      global_char := #0;
 
156
{$ifndef tp}
 
157
      global_s64bit := 0;
 
158
      global_class := nil;
 
159
{$endif}
 
160
     end;
 
161
 
 
162
 
 
163
    procedure clear_values;
 
164
     begin
 
165
      value_u8bit := 0;
 
166
      value_u16bit := 0;
 
167
      value_s32bit := 0;
 
168
      value_s32real := 0.0;
 
169
      value_s64real  := 0.0;
 
170
      value_proc := nil;
 
171
      value_ptr := nil;
 
172
{$ifndef tp}
 
173
      value_s64bit := 0;
 
174
      value_class := nil;
 
175
{$endif}
 
176
      fillchar(value_smallrec, sizeof(value_smallrec), #0);
 
177
      fillchar(value_largerec, sizeof(value_largerec), #0);
 
178
      value_smallset := [];
 
179
      value_smallstring := '';
 
180
      value_bigstring   := '';
 
181
      value_largeset := [];
 
182
      fillchar(value_smallarray, sizeof(value_smallarray), #0);
 
183
      value_boolean := false;
 
184
      value_char:=#0;
 
185
     end;
 
186
 
 
187
 
 
188
  procedure testprocedure;
 
189
   begin
 
190
   end;
 
191
 
 
192
   function getu8bit : byte;
 
193
    begin
 
194
      getu8bit:=RESULT_U8BIT;
 
195
    end;
 
196
 
 
197
   function getu16bit: word;
 
198
     begin
 
199
       getu16bit:=RESULT_U16BIT;
 
200
     end;
 
201
 
 
202
   function gets32bit: longint;
 
203
    begin
 
204
      gets32bit:=RESULT_S32BIT;
 
205
    end;
 
206
 
 
207
   function gets64bit: int64;
 
208
    begin
 
209
      gets64bit:=RESULT_S64BIT;
 
210
    end;
 
211
 
 
212
 
 
213
   function gets32real: single;
 
214
    begin
 
215
      gets32real:=RESULT_S32REAL;
 
216
    end;
 
217
 
 
218
   function gets64real: double;
 
219
    begin
 
220
      gets64real:=RESULT_S64REAL;
 
221
    end;
 
222
 
 
223
  {************************************************************************}
 
224
  {                           CONST  PARAMETERS                            }
 
225
  {************************************************************************}
 
226
  procedure proc_const_s32bit(const v : longint);
 
227
   begin
 
228
     global_s32bit := v;
 
229
   end;
 
230
 
 
231
{$ifndef tp}
 
232
  procedure proc_const_s64bit(const v: int64);
 
233
   begin
 
234
     global_s64bit:= v;
 
235
   end;
 
236
 
 
237
  procedure proc_const_smallarray_const_1(const arr : array of const);
 
238
  var
 
239
   i: integer;
 
240
  begin
 
241
    for i:=0 to high(arr) do
 
242
     begin
 
243
       case arr[i].vtype of
 
244
        vtInteger : global_u8bit := arr[i].vinteger and $ff;
 
245
        vtBoolean : global_boolean := arr[i].vboolean;
 
246
        vtChar : global_char := arr[i].vchar;
 
247
        vtExtended : global_s64real := arr[i].VExtended^;
 
248
        vtString :  global_bigstring := arr[i].VString^;
 
249
        vtPointer : ;
 
250
        vtPChar : global_ptr := arr[i].VPchar;
 
251
        vtObject : ;
 
252
{        vtClass : global_class := (arr[i].VClass) as tclass1;}
 
253
        vtAnsiString : ;
 
254
        vtInt64 :  global_s64bit := arr[i].vInt64^;
 
255
        else
 
256
          RunError(255);
 
257
       end;
 
258
     end; {endfor}
 
259
  end;
 
260
 
 
261
 
 
262
  procedure proc_const_smallarray_const_2(const arr : array of const);
 
263
  var
 
264
   i: integer;
 
265
  begin
 
266
     if high(arr)<0 then
 
267
       global_u8bit := RESULT_U8BIT;
 
268
  end;
 
269
 
 
270
{$endif}
 
271
 
 
272
 
 
273
  procedure proc_const_smallrecord(const smallrec : tsmallrecord);
 
274
   begin
 
275
     if (smallrec.b = RESULT_U8BIT) and (smallrec.w = RESULT_U16BIT) then
 
276
       global_u8bit := RESULT_U8BIT;
 
277
   end;
 
278
 
 
279
 
 
280
  procedure proc_const_largerecord(const largerec : tlargerecord);
 
281
   begin
 
282
     if (largerec.b[1] = RESULT_U8BIT) and (largerec.b[2] = RESULT_U8BIT) then
 
283
       global_u8bit := RESULT_U8BIT;
 
284
   end;
 
285
 
 
286
  procedure proc_const_smallset(const smallset : tsmallset);
 
287
   begin
 
288
     if A_D in smallset then
 
289
       global_u8bit := RESULT_U8BIT;
 
290
   end;
 
291
 
 
292
 
 
293
  procedure proc_const_largeset(const largeset : tlargeset);
 
294
   begin
 
295
     if 'I' in largeset then
 
296
       global_u8bit := RESULT_U8BIT;
 
297
   end;
 
298
 
 
299
 
 
300
  procedure proc_const_smallstring(const s:tsmallstring);
 
301
   begin
 
302
     if s = RESULT_SMALLSTRING then
 
303
       global_u8bit := RESULT_u8BIT;
 
304
   end;
 
305
 
 
306
 
 
307
  procedure proc_const_bigstring(const s:shortstring);
 
308
   begin
 
309
     if s = RESULT_BIGSTRING then
 
310
       global_u8bit := RESULT_u8BIT;
 
311
   end;
 
312
 
 
313
 
 
314
  procedure proc_const_smallarray(const arr : tsmallarray);
 
315
  begin
 
316
    if arr[SMALL_INDEX] = RESULT_U8BIT then
 
317
      global_u8bit := RESULT_U8BIT;
 
318
  end;
 
319
 
 
320
  procedure proc_const_smallarray_open(const arr : array of byte);
 
321
  begin
 
322
    { form 0 to N-1 indexes in open arrays }
 
323
    if arr[SMALL_INDEX-1] = RESULT_U8BIT then
 
324
      global_u8bit := RESULT_U8BIT;
 
325
  end;
 
326
 
 
327
 
 
328
 
 
329
 
 
330
  procedure proc_const_formaldef_array(const buf);
 
331
  var
 
332
   p: pchar;
 
333
  begin
 
334
    { array is indexed from 1 }
 
335
    p := @buf;
 
336
    global_u8bit := byte(p[SMALL_INDEX-1]);
 
337
  end;
 
338
 
 
339
 
 
340
  {************************************************************************}
 
341
  {                   MIXED   CONST  PARAMETERS                            }
 
342
  {************************************************************************}
 
343
  procedure proc_const_s32bit_mixed(b1: byte; const v : longint; b2: byte);
 
344
   begin
 
345
     global_s32bit := v;
 
346
     value_u8bit := b2;
 
347
   end;
 
348
 
 
349
{$ifndef tp}
 
350
  procedure proc_const_s64bit_mixed(b1 : byte; const v: int64; b2: byte);
 
351
   begin
 
352
     global_s64bit:= v;
 
353
     value_u8bit := b2;
 
354
   end;
 
355
 
 
356
  procedure proc_const_smallarray_const_1_mixed(b1 : byte; const arr : array of const; b2: byte);
 
357
  var
 
358
   i: integer;
 
359
  begin
 
360
    for i:=0 to high(arr) do
 
361
     begin
 
362
       case arr[i].vtype of
 
363
        vtInteger : global_u8bit := arr[i].vinteger and $ff;
 
364
        vtBoolean : global_boolean := arr[i].vboolean;
 
365
        vtChar : global_char := arr[i].vchar;
 
366
        vtExtended : global_s64real := arr[i].VExtended^;
 
367
        vtString :  global_bigstring := arr[i].VString^;
 
368
        vtPointer : ;
 
369
        vtPChar : global_ptr := arr[i].VPchar;
 
370
        vtObject : ;
 
371
{        vtClass : global_class := (arr[i].VClass) as tclass1;}
 
372
        vtAnsiString : ;
 
373
        vtInt64 :  global_s64bit := arr[i].vInt64^;
 
374
        else
 
375
          RunError(255);
 
376
       end;
 
377
     end; {endfor}
 
378
     value_u8bit := b2;
 
379
  end;
 
380
 
 
381
 
 
382
  procedure proc_const_smallarray_const_2_mixed(b1: byte; const arr : array of const; b2: byte);
 
383
  var
 
384
   i: integer;
 
385
  begin
 
386
     if high(arr)<0 then
 
387
       global_u8bit := RESULT_U8BIT;
 
388
     value_u8bit := b2;
 
389
  end;
 
390
{$endif}
 
391
 
 
392
 
 
393
  procedure proc_const_smallrecord_mixed(b1 : byte; const smallrec : tsmallrecord; b2: byte);
 
394
   begin
 
395
     if (smallrec.b = RESULT_U8BIT) and (smallrec.w = RESULT_U16BIT) then
 
396
       global_u8bit := RESULT_U8BIT;
 
397
     value_u8bit := b2;
 
398
   end;
 
399
 
 
400
 
 
401
  procedure proc_const_largerecord_mixed(b1: byte; const largerec : tlargerecord; b2: byte);
 
402
   begin
 
403
     if (largerec.b[1] = RESULT_U8BIT) and (largerec.b[2] = RESULT_U8BIT) then
 
404
       global_u8bit := RESULT_U8BIT;
 
405
     value_u8bit := b2;
 
406
   end;
 
407
 
 
408
  procedure proc_const_smallset_mixed(b1: byte; const smallset : tsmallset; b2: byte);
 
409
   begin
 
410
     if A_D in smallset then
 
411
       global_u8bit := RESULT_U8BIT;
 
412
     value_u8bit := b2;
 
413
   end;
 
414
 
 
415
 
 
416
  procedure proc_const_largeset_mixed(b1: byte; const largeset : tlargeset; b2: byte);
 
417
   begin
 
418
     if 'I' in largeset then
 
419
       global_u8bit := RESULT_U8BIT;
 
420
     value_u8bit := b2;
 
421
   end;
 
422
 
 
423
 
 
424
  procedure proc_const_smallstring_mixed(b1: byte; const s:tsmallstring; b2: byte);
 
425
   begin
 
426
     if s = RESULT_SMALLSTRING then
 
427
       global_u8bit := RESULT_u8BIT;
 
428
     value_u8bit := b2;
 
429
   end;
 
430
 
 
431
 
 
432
  procedure proc_const_bigstring_mixed(b1: byte; const s:shortstring; b2: byte);
 
433
   begin
 
434
     if s = RESULT_BIGSTRING then
 
435
       global_u8bit := RESULT_u8BIT;
 
436
     value_u8bit := b2;
 
437
   end;
 
438
 
 
439
 
 
440
  procedure proc_const_smallarray_mixed(b1: byte; const arr : tsmallarray; b2: byte);
 
441
  begin
 
442
    if arr[SMALL_INDEX] = RESULT_U8BIT then
 
443
      global_u8bit := RESULT_U8BIT;
 
444
     value_u8bit := b2;
 
445
  end;
 
446
 
 
447
  procedure proc_const_smallarray_open_mixed(b1: byte; const arr : array of byte; b2: byte);
 
448
  begin
 
449
    { form 0 to N-1 indexes in open arrays }
 
450
    if arr[high(arr)] = RESULT_U8BIT then
 
451
      global_u8bit := RESULT_U8BIT;
 
452
     value_u8bit := b2;
 
453
  end;
 
454
 
 
455
 
 
456
 
 
457
 
 
458
  procedure proc_const_formaldef_array_mixed(b1: byte; const buf; b2: byte);
 
459
  var
 
460
   p: pchar;
 
461
  begin
 
462
    { array is indexed from 1 }
 
463
    p := @buf;
 
464
    global_u8bit := byte(p[SMALL_INDEX-1]);
 
465
    value_u8bit := b2;
 
466
  end;
 
467
 
 
468
 
 
469
var
 
470
  failed: boolean;
 
471
  pp : ^pchar;
 
472
begin
 
473
  {***************************** NORMAL TESTS *******************************}
 
474
  write('Const parameter test (src : LOC_REGISTER (orddef)))...');
 
475
  clear_globals;
 
476
  clear_values;
 
477
  failed:=false;
 
478
 
 
479
  proc_const_s32bit(gets32bit);
 
480
  if global_s32bit <> RESULT_S32BIT then
 
481
    failed:=true;
 
482
{$ifndef tp}
 
483
  proc_const_s64bit(gets64bit);
 
484
  if global_s64bit <> RESULT_S64BIT then
 
485
    failed:=true;
 
486
{$endif}
 
487
 
 
488
  if failed then
 
489
    fail
 
490
  else
 
491
    WriteLn('Passed!');
 
492
 
 
493
  write('Const parameter test (src : LOC_REFERENCE (recorddef)))...');
 
494
  clear_globals;
 
495
  clear_values;
 
496
  failed := false;
 
497
 
 
498
  value_smallrec.b := RESULT_U8BIT;
 
499
  value_smallrec.w := RESULT_U16BIT;
 
500
  proc_const_smallrecord(value_smallrec);
 
501
  if global_u8bit <> RESULT_U8BIT then
 
502
    failed := true;
 
503
 
 
504
  clear_globals;
 
505
  clear_values;
 
506
  fillchar(value_largerec,sizeof(value_largerec),RESULT_U8BIT);
 
507
  proc_const_largerecord(value_largerec);
 
508
  if global_u8bit <> RESULT_U8BIT then
 
509
    failed := true;
 
510
 
 
511
  if failed then
 
512
    fail
 
513
  else
 
514
    WriteLn('Passed!');
 
515
 
 
516
 
 
517
 
 
518
  write('const parameter test (src : LOC_REFERENCE (setdef)))...');
 
519
  clear_globals;
 
520
  clear_values;
 
521
  failed := false;
 
522
 
 
523
  value_smallset := [A_A,A_D];
 
524
  proc_const_smallset(value_smallset);
 
525
  if global_u8bit <> RESULT_U8BIT then
 
526
    failed := true;
 
527
 
 
528
  clear_globals;
 
529
  clear_values;
 
530
  value_largeset := ['I'];
 
531
  proc_const_largeset(value_largeset);
 
532
  if global_u8bit <> RESULT_U8BIT then
 
533
    failed := true;
 
534
 
 
535
  if failed then
 
536
    fail
 
537
  else
 
538
    WriteLn('Passed!');
 
539
 
 
540
 
 
541
 
 
542
 
 
543
 
 
544
  write('const parameter test (src : LOC_REFERENCE (stringdef)))...');
 
545
  clear_globals;
 
546
  clear_values;
 
547
  failed := false;
 
548
  value_smallstring := RESULT_SMALLSTRING;
 
549
 
 
550
  proc_const_smallstring(value_smallstring);
 
551
  if global_u8bit <> RESULT_U8BIT then
 
552
    failed := true;
 
553
 
 
554
  clear_globals;
 
555
  clear_values;
 
556
  value_bigstring := RESULT_BIGSTRING;
 
557
  proc_const_bigstring(value_bigstring);
 
558
  if global_u8bit <> RESULT_U8BIT then
 
559
    failed := true;
 
560
 
 
561
  if failed then
 
562
    fail
 
563
  else
 
564
    WriteLn('Passed!');
 
565
 
 
566
 
 
567
 
 
568
 
 
569
  write('Const parameter test (src : LOC_REFERENCE (formaldef)))...');
 
570
  clear_globals;
 
571
  clear_values;
 
572
  failed:=false;
 
573
 
 
574
  value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
 
575
  proc_const_formaldef_array(value_smallarray);
 
576
  if global_u8bit <> RESULT_U8BIT then
 
577
    failed := true;
 
578
 
 
579
  if failed then
 
580
    fail
 
581
  else
 
582
    WriteLn('Passed!');
 
583
 
 
584
 
 
585
 
 
586
  write('Const parameter test (src : LOC_REFERENCE (arraydef)))...');
 
587
 
 
588
  clear_globals;
 
589
  clear_values;
 
590
  failed:=false;
 
591
 
 
592
  value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
 
593
  proc_const_smallarray(value_smallarray);
 
594
  if global_u8bit <> RESULT_U8BIT then
 
595
    failed := true;
 
596
 
 
597
  clear_globals;
 
598
  clear_values;
 
599
 
 
600
  value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
 
601
  proc_const_smallarray_open(value_smallarray);
 
602
  if global_u8bit <> RESULT_U8BIT then
 
603
    failed := true;
 
604
 
 
605
{$ifndef tp}
 
606
  clear_globals;
 
607
  clear_values;
 
608
 
 
609
  value_u8bit := RESULT_U8BIT;
 
610
  value_ptr := RESULT_PCHAR;
 
611
  value_s64bit := RESULT_S64BIT;
 
612
  value_smallstring := RESULT_SMALLSTRING;
 
613
  value_class := tclass1.create;
 
614
  value_boolean := RESULT_BOOLEAN;
 
615
  value_char := RESULT_CHAR;
 
616
  value_s64real:=RESULT_S64REAL;
 
617
  proc_const_smallarray_const_1([value_u8bit,value_ptr,value_s64bit,value_char,value_smallstring,value_s64real,
 
618
    value_boolean,value_class]);
 
619
 
 
620
  if global_u8bit <> RESULT_U8BIT then
 
621
    failed := true;
 
622
 
 
623
  if global_char <> RESULT_CHAR then
 
624
    failed := true;
 
625
  if global_boolean <> RESULT_BOOLEAN then
 
626
    failed:=true;
 
627
  if trunc(global_s64real) <> trunc(RESULT_S64REAL) then
 
628
     failed := true;
 
629
  if global_bigstring <> RESULT_SMALLSTRING then
 
630
     failed := true;
 
631
  if global_ptr <> value_ptr then
 
632
     failed := true;
 
633
{  if value_class <> global_class then
 
634
     failed := true;!!!!!!!!!!!!!!!!!!!!}
 
635
  if global_s64bit <> RESULT_S64BIT then
 
636
     failed := true;
 
637
  if assigned(value_class) then
 
638
    value_class.destroy;
 
639
 
 
640
  global_u8bit := 0;
 
641
  proc_const_smallarray_const_2([]);
 
642
  if global_u8bit <> RESULT_U8BIT then
 
643
    failed := true;
 
644
{$endif}
 
645
 
 
646
  if failed then
 
647
    fail
 
648
  else
 
649
    WriteLn('Passed!');
 
650
 
 
651
 
 
652
  {***************************** MIXED  TESTS *******************************}
 
653
  write('Mixed const parameter test (src : LOC_REGISTER (orddef)))...');
 
654
  clear_globals;
 
655
  clear_values;
 
656
  failed:=false;
 
657
 
 
658
  proc_const_s32bit_mixed(RESULT_U8BIT,gets32bit,RESULT_U8BIT);
 
659
  if global_s32bit <> RESULT_S32BIT then
 
660
    failed:=true;
 
661
  if value_u8bit <> RESULT_U8BIT then
 
662
    failed := true;
 
663
{$ifndef tp}
 
664
  proc_const_s64bit_mixed(RESULT_U8BIT,gets64bit,RESULT_U8BIT);
 
665
  if global_s64bit <> RESULT_S64BIT then
 
666
    failed:=true;
 
667
  if value_u8bit <> RESULT_U8BIT then
 
668
    failed := true;
 
669
{$endif}
 
670
  if failed then
 
671
    fail
 
672
  else
 
673
    WriteLn('Passed!');
 
674
 
 
675
  write('Mixed const parameter test (src : LOC_REFERENCE (recorddef)))...');
 
676
  clear_globals;
 
677
  clear_values;
 
678
  failed := false;
 
679
 
 
680
  value_smallrec.b := RESULT_U8BIT;
 
681
  value_smallrec.w := RESULT_U16BIT;
 
682
  proc_const_smallrecord_mixed(RESULT_U8BIT,value_smallrec,RESULT_U8BIT);
 
683
  if global_u8bit <> RESULT_U8BIT then
 
684
    failed := true;
 
685
  if value_u8bit <> RESULT_U8BIT then
 
686
    failed := true;
 
687
 
 
688
  clear_globals;
 
689
  clear_values;
 
690
  fillchar(value_largerec,sizeof(value_largerec),RESULT_U8BIT);
 
691
  proc_const_largerecord_mixed(RESULT_U8BIT,value_largerec,RESULT_U8BIT);
 
692
  if global_u8bit <> RESULT_U8BIT then
 
693
    failed := true;
 
694
  if value_u8bit <> RESULT_U8BIT then
 
695
    failed := true;
 
696
 
 
697
  if failed then
 
698
    fail
 
699
  else
 
700
    WriteLn('Passed!');
 
701
 
 
702
 
 
703
 
 
704
  write('Mixed const parameter test (src : LOC_REFERENCE (setdef)))...');
 
705
  clear_globals;
 
706
  clear_values;
 
707
  failed := false;
 
708
 
 
709
  value_smallset := [A_A,A_D];
 
710
  proc_const_smallset_mixed(RESULT_U8BIT,value_smallset,RESULT_U8BIT);
 
711
  if global_u8bit <> RESULT_U8BIT then
 
712
    failed := true;
 
713
  if value_u8bit <> RESULT_U8BIT then
 
714
    failed := true;
 
715
 
 
716
  clear_globals;
 
717
  clear_values;
 
718
  value_largeset := ['I'];
 
719
  proc_const_largeset_mixed(RESULT_U8BIT,value_largeset,RESULT_U8BIT);
 
720
  if global_u8bit <> RESULT_U8BIT then
 
721
    failed := true;
 
722
  if value_u8bit <> RESULT_U8BIT then
 
723
    failed := true;
 
724
 
 
725
  if failed then
 
726
    fail
 
727
  else
 
728
    WriteLn('Passed!');
 
729
 
 
730
 
 
731
  write('Mixed const parameter test (src : LOC_REFERENCE (stringdef)))...');
 
732
  clear_globals;
 
733
  clear_values;
 
734
  failed := false;
 
735
  value_smallstring := RESULT_SMALLSTRING;
 
736
 
 
737
  proc_const_smallstring_mixed(RESULT_U8BIT,value_smallstring,RESULT_U8BIT);
 
738
  if global_u8bit <> RESULT_U8BIT then
 
739
    failed := true;
 
740
  if value_u8bit <> RESULT_U8BIT then
 
741
    failed := true;
 
742
 
 
743
  clear_globals;
 
744
  clear_values;
 
745
  value_bigstring := RESULT_BIGSTRING;
 
746
  proc_const_bigstring_mixed(RESULT_U8BIT,value_bigstring,RESULT_U8BIT);
 
747
  if global_u8bit <> RESULT_U8BIT then
 
748
    failed := true;
 
749
  if value_u8bit <> RESULT_U8BIT then
 
750
    failed := true;
 
751
 
 
752
  if failed then
 
753
    fail
 
754
  else
 
755
    WriteLn('Passed!');
 
756
 
 
757
  write('Mixed const parameter test (src : LOC_REFERENCE (formaldef)))...');
 
758
  clear_globals;
 
759
  clear_values;
 
760
  failed:=false;
 
761
 
 
762
  value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
 
763
  proc_const_formaldef_array_mixed(RESULT_U8BIT,value_smallarray,RESULT_U8BIT);
 
764
  if global_u8bit <> RESULT_U8BIT then
 
765
    failed := true;
 
766
  if value_u8bit <> RESULT_U8BIT then
 
767
    failed := true;
 
768
 
 
769
  if failed then
 
770
    fail
 
771
  else
 
772
    WriteLn('Passed!');
 
773
 
 
774
 
 
775
 
 
776
  write('Mixed const parameter test (src : LOC_REFERENCE (arraydef)))...');
 
777
 
 
778
  clear_globals;
 
779
  clear_values;
 
780
  failed:=false;
 
781
 
 
782
  value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
 
783
  proc_const_smallarray_mixed(RESULT_U8BIt,value_smallarray,RESULT_U8BIT);
 
784
  if global_u8bit <> RESULT_U8BIT then
 
785
    failed := true;
 
786
  if value_u8bit <> RESULT_U8BIT then
 
787
    failed := true;
 
788
 
 
789
  clear_globals;
 
790
  clear_values;
 
791
 
 
792
  value_smallarray[SMALL_INDEX] := RESULT_U8BIT;
 
793
  proc_const_smallarray_open_mixed(RESULT_U8BIT,value_smallarray,RESULT_U8BIT);
 
794
  if global_u8bit <> RESULT_U8BIT then
 
795
    failed := true;
 
796
  if value_u8bit <> RESULT_U8BIT then
 
797
    failed := true;
 
798
 
 
799
{$ifndef tp}
 
800
  clear_globals;
 
801
  clear_values;
 
802
 
 
803
  value_u8bit := RESULT_U8BIT;
 
804
  value_ptr := RESULT_PCHAR;
 
805
  value_s64bit := RESULT_S64BIT;
 
806
  value_smallstring := RESULT_SMALLSTRING;
 
807
  value_class := tclass1.create;
 
808
  value_boolean := RESULT_BOOLEAN;
 
809
  value_char := RESULT_CHAR;
 
810
  value_s64real:=RESULT_S64REAL;
 
811
  proc_const_smallarray_const_1_mixed(RESULT_U8BIT, [value_u8bit,value_ptr,value_s64bit,value_char,value_smallstring,
 
812
    value_s64real,value_boolean,value_class],RESULT_U8BIT);
 
813
 
 
814
  if global_u8bit <> RESULT_U8BIT then
 
815
    failed := true;
 
816
 
 
817
  if global_char <> RESULT_CHAR then
 
818
    failed := true;
 
819
  if global_boolean <> RESULT_BOOLEAN then
 
820
    failed:=true;
 
821
  if trunc(global_s64real) <> trunc(RESULT_S64REAL) then
 
822
     failed := true;
 
823
  if global_bigstring <> RESULT_SMALLSTRING then
 
824
     failed := true;
 
825
  if global_ptr <> value_ptr then
 
826
     failed := true;
 
827
{  if value_class <> global_class then
 
828
     failed := true;!!!!!!!!!!!!!!!!!!!!}
 
829
  if global_s64bit <> RESULT_S64BIT then
 
830
     failed := true;
 
831
  if assigned(value_class) then
 
832
    value_class.destroy;
 
833
  if value_u8bit <> RESULT_U8BIT then
 
834
    failed := true;
 
835
 
 
836
  global_u8bit := 0;
 
837
  proc_const_smallarray_const_2_mixed(RESULT_U8BIT,[],RESULT_U8BIT);
 
838
  if global_u8bit <> RESULT_U8BIT then
 
839
    failed := true;
 
840
  if value_u8bit <> RESULT_U8BIT then
 
841
    failed := true;
 
842
{$endif}
 
843
 
 
844
  if failed then
 
845
    fail
 
846
  else
 
847
    WriteLn('Passed!');
 
848
end.