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{ (value parameters with register calling convention) } 19{****************************************************************} 20program tcalval7; 21 22{$ifdef fpc} 23{$mode objfpc} 24{$INLINE ON} 25{$endif} 26{$R+} 27{$P-} 28 29{$ifdef VER70} 30 {$define tp} 31{$endif} 32 33 34{$ifdef cpu68k} 35 {$define cpusmall} 36{$endif} 37{$ifdef cpui8086} 38 {$define cpusmall} 39{$endif} 40 41 { REAL should map to single or double } 42 { so it is not checked, since single } 43 { double nodes are checked. } 44 45 { assumes that enumdef is the same as orddef (same storage format) } 46 47 const 48{ should be defined depending on CPU target } 49{$ifdef fpc} 50 {$ifdef cpusmall} 51 BIG_INDEX = 8000; 52 SMALL_INDEX = 13; 53 {$else} 54 BIG_INDEX = 33000; 55 SMALL_INDEX = 13; { value should not be aligned! } 56 {$endif} 57{$else} 58 BIG_INDEX = 33000; 59 SMALL_INDEX = 13; { value should not be aligned! } 60{$endif} 61 RESULT_U8BIT = $55; 62 RESULT_U16BIT = $500F; 63 RESULT_S32BIT = $500F0000; 64 RESULT_S64BIT = $500F0000; 65 RESULT_S32REAL = 1777.12; 66 RESULT_S64REAL = 3444.24; 67 RESULT_BOOL8BIT = 1; 68 RESULT_BOOL16BIT = 1; 69 RESULT_BOOL32BIT = 1; 70 RESULT_PCHAR = 'Hello world'; 71 RESULT_BIGSTRING = 'Hello world'; 72 RESULT_SMALLSTRING = 'H'; 73 RESULT_CHAR = 'I'; 74 RESULT_BOOLEAN = TRUE; 75 76type 77{$ifndef tp} 78 tclass1 = class 79 end; 80{$else} 81 shortstring = string; 82{$endif} 83 84 tprocedure = procedure; 85 86 tsmallrecord = 87{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} 88 packed 89{$endif FPC_REQUIRES_PROPER_ALIGNMENT} 90 record 91 b: byte; 92 w: word; 93 end; 94 95 tlargerecord = packed record 96 b: array[1..BIG_INDEX] of byte; 97 end; 98 99 tsmallarray = packed array[1..SMALL_INDEX] of byte; 100 101 tsmallsetenum = 102 (A_A,A_B,A_C,A_D); 103 104 tsmallset = set of tsmallsetenum; 105 tlargeset = set of char; 106 107 tsmallstring = string[2]; 108 109 110 111 112 113var 114 global_u8bit : byte; 115 global_u16bit : word; 116 global_s32bit : longint; 117 global_s32real : single; 118 global_s64real : double; 119 global_ptr : pchar; 120 global_proc : tprocedure; 121 global_bigstring : shortstring; 122 global_boolean : boolean; 123 global_char : char; 124{$ifndef tp} 125 global_class : tclass1; 126 global_s64bit : int64; 127 value_s64bit : int64; 128 value_class : tclass1; 129{$endif} 130 value_u8bit : byte; 131 value_u16bit : word; 132 value_s32bit : longint; 133 value_s32real : single; 134 value_s64real : double; 135 value_proc : tprocedure; 136 value_ptr : pchar; 137 value_smallrec : tsmallrecord; 138 value_largerec : tlargerecord; 139 value_smallset : tsmallset; 140 value_smallstring : tsmallstring; 141 value_bigstring : shortstring; 142 value_largeset : tlargeset; 143 value_smallarray : tsmallarray; 144 value_boolean : boolean; 145 value_char : char; 146 147 procedure fail; 148 begin 149 WriteLn('Failure.'); 150 halt(1); 151 end; 152 153 154 procedure clear_globals; 155 begin 156 global_u8bit := 0; 157 global_u16bit := 0; 158 global_s32bit := 0; 159 global_s32real := 0.0; 160 global_s64real := 0.0; 161 global_ptr := nil; 162 global_proc := nil; 163 global_bigstring := ''; 164 global_boolean := false; 165 global_char := #0; 166{$ifndef tp} 167 global_s64bit := 0; 168 global_class := nil; 169{$endif} 170 end; 171 172 173 procedure clear_values; 174 begin 175 value_u8bit := 0; 176 value_u16bit := 0; 177 value_s32bit := 0; 178 value_s32real := 0.0; 179 value_s64real := 0.0; 180 value_proc := nil; 181 value_ptr := nil; 182 fillchar(value_smallrec, sizeof(value_smallrec), #0); 183 fillchar(value_largerec, sizeof(value_largerec), #0); 184 value_smallset := []; 185 value_smallstring := ''; 186 value_bigstring := ''; 187 value_largeset := []; 188 fillchar(value_smallarray, sizeof(value_smallarray), #0); 189 value_boolean := false; 190 value_char:=#0; 191{$ifndef tp} 192 value_s64bit := 0; 193 value_class := nil; 194{$endif} 195 end; 196 197 198 procedure testprocedure; 199 begin 200 end; 201 202 function getu8bit : byte; 203 begin 204 getu8bit:=RESULT_U8BIT; 205 end; 206 207 function getu16bit: word; 208 begin 209 getu16bit:=RESULT_U16BIT; 210 end; 211 212 function gets32bit: longint; 213 begin 214 gets32bit:=RESULT_S32BIT; 215 end; 216 217 function gets64bit: int64; 218 begin 219 gets64bit:=RESULT_S64BIT; 220 end; 221 222 223 function gets32real: single; 224 begin 225 gets32real:=RESULT_S32REAL; 226 end; 227 228 function gets64real: double; 229 begin 230 gets64real:=RESULT_S64REAL; 231 end; 232 233{ ***************************************************************** } 234{ VALUE PARAMETERS } 235{ ***************************************************************** } 236 237 procedure proc_value_u8bit(v: byte);register; 238 begin 239 global_u8bit := v; 240 end; 241 242 243 procedure proc_value_u16bit(v: word);register; 244 begin 245 global_u16bit := v; 246 end; 247 248 249 procedure proc_value_s32bit(v : longint);register; 250 begin 251 global_s32bit := v; 252 end; 253 254 255 256 257 procedure proc_value_bool8bit(v: boolean);register; 258 begin 259 { boolean should be 8-bit always! } 260 if sizeof(boolean) <> 1 then RunError(255); 261 global_u8bit := byte(v); 262 end; 263 264 265 procedure proc_value_bool16bit(v: wordbool);register; 266 begin 267 global_u16bit := word(v); 268 end; 269 270 271 procedure proc_value_bool32bit(v : longbool);register; 272 begin 273 global_s32bit := longint(v); 274 end; 275 276 277 procedure proc_value_s32real(v : single);register; 278 begin 279 global_s32real := v; 280 end; 281 282 procedure proc_value_s64real(v: double);register; 283 begin 284 global_s64real:= v; 285 end; 286 287 288 procedure proc_value_pointerdef(p : pchar);register; 289 begin 290 global_ptr:=p; 291 end; 292 293 294 procedure proc_value_procvardef(p : tprocedure);register; 295 begin 296 global_proc:=p; 297 end; 298 299 300 301 302 procedure proc_value_smallrecord(smallrec : tsmallrecord);register; 303 begin 304 if (smallrec.b = RESULT_U8BIT) and (smallrec.w = RESULT_U16BIT) then 305 global_u8bit := RESULT_U8BIT; 306 end; 307 308 309 procedure proc_value_largerecord(largerec : tlargerecord);register; 310 begin 311 if (largerec.b[1] = RESULT_U8BIT) and (largerec.b[2] = RESULT_U8BIT) then 312 global_u8bit := RESULT_U8BIT; 313 end; 314 315 procedure proc_value_smallset(smallset : tsmallset);register; 316 begin 317 if A_D in smallset then 318 global_u8bit := RESULT_U8BIT; 319 end; 320 321 322 procedure proc_value_largeset(largeset : tlargeset);register; 323 begin 324 if 'I' in largeset then 325 global_u8bit := RESULT_U8BIT; 326 end; 327 328 procedure proc_value_smallstring(s:tsmallstring);register; 329 begin 330 if s = RESULT_SMALLSTRING then 331 global_u8bit := RESULT_u8BIT; 332 end; 333 334 335 procedure proc_value_bigstring(s:shortstring);register; 336 begin 337 if s = RESULT_BIGSTRING then 338 global_u8bit := RESULT_u8BIT; 339 end; 340 341 342 procedure proc_value_smallarray(arr : tsmallarray);register; 343 begin 344 if arr[SMALL_INDEX] = RESULT_U8BIT then 345 global_u8bit := RESULT_U8BIT; 346 end; 347 348 procedure proc_value_smallarray_open(arr : array of byte);register; 349 begin 350 { form 0 to N-1 indexes in open arrays } 351 if arr[SMALL_INDEX-1] = RESULT_U8BIT then 352 global_u8bit := RESULT_U8BIT; 353 end; 354 355{$ifndef tp} 356 procedure proc_value_classrefdef(obj : tclass1);register; 357 begin 358 global_class:=obj; 359 end; 360 361 362 procedure proc_value_smallarray_const_1(arr : array of const);register; 363 var 364 i: integer; 365 begin 366 for i:=0 to high(arr) do 367 begin 368 case arr[i].vtype of 369 vtInteger : global_u8bit := arr[i].vinteger and $ff; 370 vtBoolean : global_boolean := arr[i].vboolean; 371 vtChar : global_char := arr[i].vchar; 372 vtExtended : global_s64real := arr[i].VExtended^; 373 vtString : global_bigstring := arr[i].VString^; 374 vtPointer : ; 375 vtPChar : global_ptr := arr[i].VPchar; 376 vtObject : ; 377{ vtClass : global_class := (arr[i].VClass) as tclass1;} 378 vtAnsiString : ; 379 vtInt64 : global_s64bit := arr[i].vInt64^; 380 else 381 RunError(255); 382 end; 383 end; {endfor} 384 end; 385 386 387 procedure proc_value_smallarray_const_2(arr : array of const);register; 388 var 389 i: integer; 390 begin 391 if high(arr)<0 then 392 global_u8bit := RESULT_U8BIT; 393 end; 394 395 procedure proc_value_s64bit(v: int64);register; 396 begin 397 global_s64bit:= v; 398 end; 399{$endif} 400 401 {********************************* MIXED PARAMETERS *************************} 402 403 procedure proc_value_u8bit_mixed(b1 : byte; v: byte; b2: byte);register; 404 begin 405 global_u8bit := v; 406 value_u8bit := b2; 407 end; 408 409 410 procedure proc_value_u16bit_mixed(b1: byte; v: word; b2: byte);register; 411 begin 412 global_u16bit := v; 413 value_u8bit := b2; 414 end; 415 416 417 procedure proc_value_s32bit_mixed(b1 : byte; v : longint; b2: byte);register; 418 begin 419 global_s32bit := v; 420 value_u8bit := b2; 421 end; 422 423 424 425 426 procedure proc_value_bool8bit_mixed(b1: byte; v: boolean; b2: byte);register; 427 begin 428 { boolean should be 8-bit always! } 429 if sizeof(boolean) <> 1 then RunError(255); 430 global_u8bit := byte(v); 431 value_u8bit := b2; 432 end; 433 434 435 procedure proc_value_bool16bit_mixed(b1 : byte; v: wordbool; b2: byte);register; 436 begin 437 global_u16bit := word(v); 438 value_u8bit := b2; 439 end; 440 441 442 procedure proc_value_bool32bit_mixed(b1 : byte; v : longbool; b2: byte);register; 443 begin 444 global_s32bit := longint(v); 445 value_u8bit := b2; 446 end; 447 448 449 procedure proc_value_s32real_mixed(b1: byte; v : single; b2: byte);register; 450 begin 451 global_s32real := v; 452 value_u8bit := b2; 453 end; 454 455 procedure proc_value_s64real_mixed(b1: byte; v: double; b2: byte);register; 456 begin 457 global_s64real:= v; 458 value_u8bit := b2; 459 end; 460 461 462 procedure proc_value_pointerdef_mixed(b1: byte; p : pchar; b2: byte);register; 463 begin 464 global_ptr:=p; 465 value_u8bit := b2; 466 end; 467 468 469 procedure proc_value_procvardef_mixed(b1: byte; p : tprocedure; b2: byte);register; 470 begin 471 global_proc:=p; 472 value_u8bit := b2; 473 end; 474 475 476 477 478 procedure proc_value_smallrecord_mixed(b1: byte; smallrec : tsmallrecord; b2: byte);register; 479 begin 480 if (smallrec.b = RESULT_U8BIT) and (smallrec.w = RESULT_U16BIT) then 481 global_u8bit := RESULT_U8BIT; 482 value_u8bit := b2; 483 end; 484 485 486 procedure proc_value_largerecord_mixed(b1: byte; largerec : tlargerecord; b2: byte);register; 487 begin 488 if (largerec.b[1] = RESULT_U8BIT) and (largerec.b[2] = RESULT_U8BIT) then 489 global_u8bit := RESULT_U8BIT; 490 value_u8bit := b2; 491 end; 492 493 procedure proc_value_smallset_mixed(b1: byte; smallset : tsmallset; b2: byte);register; 494 begin 495 if A_D in smallset then 496 global_u8bit := RESULT_U8BIT; 497 value_u8bit := b2; 498 end; 499 500 501 procedure proc_value_largeset_mixed(b1: byte; largeset : tlargeset; b2: byte);register; 502 begin 503 if 'I' in largeset then 504 global_u8bit := RESULT_U8BIT; 505 value_u8bit := b2; 506 end; 507 508 procedure proc_value_smallstring_mixed(b1: byte; s:tsmallstring; b2: byte);register; 509 begin 510 if s = RESULT_SMALLSTRING then 511 global_u8bit := RESULT_u8BIT; 512 value_u8bit := b2; 513 end; 514 515 516 procedure proc_value_bigstring_mixed(b1: byte; s:shortstring; b2: byte);register; 517 begin 518 if s = RESULT_BIGSTRING then 519 global_u8bit := RESULT_u8BIT; 520 value_u8bit := b2; 521 end; 522 523 524 procedure proc_value_smallarray_mixed(b1: byte; arr : tsmallarray; b2: byte);register; 525 begin 526 if arr[SMALL_INDEX] = RESULT_U8BIT then 527 global_u8bit := RESULT_U8BIT; 528 value_u8bit := b2; 529 end; 530 531 procedure proc_value_smallarray_open_mixed(b1: byte; arr : array of byte; b2: byte);register; 532 begin 533 { form 0 to N-1 indexes in open arrays } 534 if arr[SMALL_INDEX-1] = RESULT_U8BIT then 535 global_u8bit := RESULT_U8BIT; 536 value_u8bit := b2; 537 end; 538 539{$ifndef tp} 540 procedure proc_value_classrefdef_mixed(b1: byte; obj : tclass1; b2: byte);register; 541 begin 542 global_class:=obj; 543 value_u8bit := b2; 544 end; 545 546 547 procedure proc_value_s64bit_mixed(b1 : byte; v: int64; b2: byte);register; 548 begin 549 global_s64bit:= v; 550 value_u8bit := b2; 551 end; 552 553 554 procedure proc_value_smallarray_const_1_mixed(b1: byte; arr : array of const; b2: byte);register; 555 var 556 i: integer; 557 begin 558 for i:=0 to high(arr) do 559 begin 560 case arr[i].vtype of 561 vtInteger : global_u8bit := arr[i].vinteger and $ff; 562 vtBoolean : global_boolean := arr[i].vboolean; 563 vtChar : global_char := arr[i].vchar; 564 vtExtended : global_s64real := arr[i].VExtended^; 565 vtString : global_bigstring := arr[i].VString^; 566 vtPointer : ; 567 vtPChar : global_ptr := arr[i].VPchar; 568 vtObject : ; 569{ vtClass : global_class := (arr[i].VClass) as tclass1;} 570 vtAnsiString : ; 571 vtInt64 : global_s64bit := arr[i].vInt64^; 572 else 573 RunError(255); 574 end; 575 end; {endfor} 576 value_u8bit := b2; 577 end; 578 579 580 procedure proc_value_smallarray_const_2_mixed(b1: byte; arr : array of const; b2: byte);register; 581 var 582 i: integer; 583 begin 584 if high(arr)<0 then 585 global_u8bit := RESULT_U8BIT; 586 value_u8bit := b2; 587 end; 588{$endif} 589 590 591 592var 593 failed: boolean; 594Begin 595 {***************************** NORMAL TESTS *******************************} 596 clear_globals; 597 clear_values; 598 599 failed:=false; 600 601 { LOC_REGISTER } 602 write('Value parameter test (src : LOC_REGISTER)...'); 603 proc_value_u8bit(getu8bit); 604 if global_u8bit <> RESULT_U8BIT then 605 failed:=true; 606 proc_value_u16bit(getu16bit); 607 if global_u16bit <> RESULT_U16BIT then 608 failed:=true; 609 proc_value_s32bit(gets32bit); 610 if global_s32bit <> RESULT_S32BIT then 611 failed:=true; 612{$ifndef tp} 613 proc_value_s64bit(gets64bit); 614 if global_s64bit <> RESULT_S64BIT then 615 failed:=true; 616{$endif} 617 if failed then 618 fail 619 else 620 WriteLn('Passed!'); 621 622 623 { LOC_FPUREGISTER } 624 clear_globals; 625 clear_values; 626 failed:=false; 627 write('Value parameter test (src : LOC_FPUREGISTER)...'); 628 proc_value_s32real(gets32real); 629 if trunc(global_s32real) <> trunc(RESULT_S32REAL) then 630 failed:=true; 631 proc_value_s64real(gets64real); 632 if trunc(global_s64real) <> trunc(RESULT_S64REAL) then 633 failed:=true; 634 if failed then 635 fail 636 else 637 WriteLn('Passed!'); 638 639 640 { LOC_MEM, LOC_REFERENCE orddef } 641 clear_globals; 642 clear_values; 643 value_u8bit := RESULT_U8BIT; 644 value_u16bit := RESULT_U16BIT; 645 value_s32bit := RESULT_S32BIT; 646{$ifndef tp} 647 value_s64bit := RESULT_S64BIT; 648{$endif} 649 value_s32real := RESULT_S32REAL; 650 value_s64real := RESULT_S64REAL; 651 652 failed:=false; 653 654 { LOC_REFERENCE } 655 write('Value parameter test (src : LOC_REFERENCE (orddef/enumdef)))...'); 656 proc_value_u8bit(value_u8bit); 657 if global_u8bit <> RESULT_U8BIT then 658 failed:=true; 659 proc_value_u16bit(value_u16bit); 660 if global_u16bit <> RESULT_U16BIT then 661 failed:=true; 662 proc_value_s32bit(value_s32bit); 663 if global_s32bit <> RESULT_S32BIT then 664 failed:=true; 665{$ifndef tp} 666 proc_value_s64bit(value_s64bit); 667 if global_s64bit <> RESULT_S64BIT then 668 failed:=true; 669{$endif} 670 if failed then 671 fail 672 else 673 WriteLn('Passed!'); 674 675 676 { LOC_REFERENCE } 677 clear_globals; 678 failed:=false; 679 write('Value parameter test (src : LOC_REFERENCE (floatdef))...'); 680 proc_value_s32real(value_s32real); 681 if trunc(global_s32real) <> trunc(RESULT_S32REAL) then 682 failed:=true; 683 proc_value_s64real(value_s64real); 684 if trunc(global_s64real) <> trunc(RESULT_S64REAL) then 685 failed:=true; 686 if failed then 687 fail 688 else 689 WriteLn('Passed!'); 690 691 692 693 write('Value parameter test (src : LOC_REFERENCE (pointer))...'); 694 clear_globals; 695 clear_values; 696 failed:=false; 697 value_ptr := RESULT_PCHAR; 698 proc_value_pointerdef(value_ptr); 699 if global_ptr <> value_ptr then 700 failed := true; 701 702 703 value_proc := {$ifndef tp}@{$endif}testprocedure; 704 proc_value_procvardef(value_proc); 705 if {$ifndef fpc}@{$endif}value_proc <> {$ifndef fpc}@{$endif}global_proc then 706 failed := true; 707 708{$ifndef tp} 709 value_class := tclass1.create; 710 proc_value_classrefdef(value_class); 711 if value_class <> global_class then 712 failed := true; 713 value_class.destroy; 714{$endif} 715 if failed then 716 fail 717 else 718 WriteLn('Passed!'); 719 720 721 722 723 { LOC_REFERENCE } 724 clear_globals; 725 clear_values; 726 failed:=false; 727 value_u8bit := 0; 728 write('Value parameter test (src : LOC_FLAGS (orddef)))...'); 729 proc_value_bool8bit(value_u8bit = 0); 730 if global_u8bit <> RESULT_BOOL8BIT then 731 failed:=true; 732{* IMPOSSIBLE TO GENERATE LOC_FLAGS WITH SIZE <> S_B ON VERSION 1.0.x 733 proc_value_bool16bit(value_s64bit < 0); 734 if global_u16bit <> RESULT_BOOL16BIT then 735 failed:=true; 736 proc_value_bool32bit(bool1 and bool2); 737 if global_s32bit <> RESULT_BOOL32BIT then 738 failed:=true;*} 739 if failed then 740 fail 741 else 742 WriteLn('Passed!'); 743 744 745 746{$ifndef tp} 747 clear_globals; 748 clear_values; 749 failed:=false; 750 write('Value parameter test (src : LOC_JUMP (orddef)))...'); 751 proc_value_bool8bit(value_s64bit = 0); 752 if global_u8bit <> RESULT_BOOL8BIT then 753 failed:=true; 754{* IMPOSSIBLE TO GENERATE LOC_JUMP WITH SIZE <> S_B ON VERSION 1.0.x 755 proc_value_bool16bit(value_s64bit < 0); 756 if global_u16bit <> RESULT_BOOL16BIT then 757 failed:=true; 758 proc_value_bool32bit(bool1 and bool2); 759 if global_s32bit <> RESULT_BOOL32BIT then 760 failed:=true;*} 761 if failed then 762 fail 763 else 764 WriteLn('Passed!'); 765{$endif} 766 767 { arraydef, 768 recorddef, 769 objectdef, 770 stringdef, 771 setdef : all considered the same by code generator. 772 } 773 write('Value parameter test (src : LOC_REFERENCE (recorddef)))...'); 774 clear_globals; 775 clear_values; 776 failed := false; 777 778 value_smallrec.b := RESULT_U8BIT; 779 value_smallrec.w := RESULT_U16BIT; 780 proc_value_smallrecord(value_smallrec); 781 if global_u8bit <> RESULT_U8BIT then 782 failed := true; 783 784 clear_globals; 785 clear_values; 786 fillchar(value_largerec,sizeof(value_largerec),RESULT_U8BIT); 787 proc_value_largerecord(value_largerec); 788 if global_u8bit <> RESULT_U8BIT then 789 failed := true; 790 791 if failed then 792 fail 793 else 794 WriteLn('Passed!'); 795 796 797 798 write('Value parameter test (src : LOC_REFERENCE (setdef)))...'); 799 clear_globals; 800 clear_values; 801 failed := false; 802 803 value_smallset := [A_A,A_D]; 804 proc_value_smallset(value_smallset); 805 if global_u8bit <> RESULT_U8BIT then 806 failed := true; 807 808 clear_globals; 809 clear_values; 810 value_largeset := ['I']; 811 proc_value_largeset(value_largeset); 812 if global_u8bit <> RESULT_U8BIT then 813 failed := true; 814 815 if failed then 816 fail 817 else 818 WriteLn('Passed!'); 819 820 821 822 823 824 write('Value parameter test (src : LOC_REFERENCE (stringdef)))...'); 825 clear_globals; 826 clear_values; 827 failed := false; 828 value_smallstring := RESULT_SMALLSTRING; 829 830 proc_value_smallstring(value_smallstring); 831 if global_u8bit <> RESULT_U8BIT then 832 failed := true; 833 834 clear_globals; 835 clear_values; 836 value_bigstring := RESULT_BIGSTRING; 837 proc_value_bigstring(value_bigstring); 838 if global_u8bit <> RESULT_U8BIT then 839 failed := true; 840 841 if failed then 842 fail 843 else 844 WriteLn('Passed!'); 845 846 847 848 { open array by value with cdecl modifier!!!!!!!!!!!!!!!!!!!!!!!!!!!} 849 { DON'T KNOW WHY/HOW TO TEST!!!!! } 850 851 852 write('Value parameter test (src : LOC_REFERENCE (arraydef)))...'); 853 854 clear_globals; 855 clear_values; 856 failed:=false; 857 858 fillchar(value_smallarray,sizeof(value_smallarray),#0); 859 value_smallarray[SMALL_INDEX] := RESULT_U8BIT; 860 proc_value_smallarray(value_smallarray); 861 if global_u8bit <> RESULT_U8BIT then 862 failed := true; 863 864 clear_globals; 865 clear_values; 866 867 fillchar(value_smallarray,sizeof(value_smallarray),#0); 868 value_smallarray[SMALL_INDEX] := RESULT_U8BIT; 869 proc_value_smallarray_open(value_smallarray); 870 if global_u8bit <> RESULT_U8BIT then 871 failed := true; 872 873{$ifndef tp} 874 clear_globals; 875 clear_values; 876 877 value_u8bit := RESULT_U8BIT; 878 value_ptr := RESULT_PCHAR; 879 value_s64bit := RESULT_S64BIT; 880 value_smallstring := RESULT_SMALLSTRING; 881 value_class := tclass1.create; 882 value_boolean := RESULT_BOOLEAN; 883 value_char := RESULT_CHAR; 884 value_s64real:=RESULT_S64REAL; 885 proc_value_smallarray_const_1([value_u8bit,value_ptr,value_s64bit,value_char,value_smallstring,value_s64real, 886 value_boolean,value_class]); 887 888 if global_u8bit <> RESULT_U8BIT then 889 failed := true; 890 891 if global_char <> RESULT_CHAR then 892 failed := true; 893 if global_boolean <> RESULT_BOOLEAN then 894 failed:=true; 895 if trunc(global_s64real) <> trunc(RESULT_S64REAL) then 896 failed := true; 897 if global_bigstring <> RESULT_SMALLSTRING then 898 failed := true; 899 if global_ptr <> value_ptr then 900 failed := true; 901{ if value_class <> global_class then 902 failed := true;!!!!!!!!!!!!!!!!!!!!} 903 if global_s64bit <> RESULT_S64BIT then 904 failed := true; 905 if assigned(value_class) then 906 value_class.destroy; 907 908 global_u8bit := 0; 909 proc_value_smallarray_const_2([]); 910 if global_u8bit <> RESULT_U8BIT then 911 failed := true; 912{$endif fpc} 913 914 if failed then 915 fail 916 else 917 WriteLn('Passed!'); 918 919 {***************************** MIXED TESTS *******************************} 920 clear_globals; 921 clear_values; 922 923 failed:=false; 924 925 { LOC_REGISTER } 926 write('Mixed value parameter test (src : LOC_REGISTER)...'); 927 proc_value_u8bit_mixed(byte(NOT RESULT_U8BIT),getu8bit,RESULT_U8BIT); 928 if global_u8bit <> RESULT_U8BIT then 929 failed:=true; 930 if value_u8bit <> RESULT_U8BIT then 931 failed := true; 932 proc_value_u16bit_mixed(byte(NOT RESULT_U8BIT),getu16bit,RESULT_U8BIT); 933 if global_u16bit <> RESULT_U16BIT then 934 failed:=true; 935 if value_u8bit <> RESULT_U8BIT then 936 failed := true; 937 proc_value_s32bit_mixed(byte(NOT RESULT_U8BIT),gets32bit, RESULT_U8BIT); 938 if global_s32bit <> RESULT_S32BIT then 939 failed:=true; 940 if value_u8bit <> RESULT_U8BIT then 941 failed := true; 942{$ifndef tp} 943 proc_value_s64bit_mixed(byte(NOT RESULT_U8BIT),gets64bit,RESULT_U8BIT); 944 if global_s64bit <> RESULT_S64BIT then 945 failed:=true; 946{$endif} 947 if value_u8bit <> RESULT_U8BIT then 948 failed := true; 949 950 if failed then 951 fail 952 else 953 WriteLn('Passed!'); 954 955 956 { LOC_FPUREGISTER } 957 clear_globals; 958 clear_values; 959 failed:=false; 960 write('Mixed value parameter test (src : LOC_FPUREGISTER)...'); 961 proc_value_s32real_mixed(byte(NOT RESULT_U8BIT), gets32real, RESULT_U8BIT); 962 if value_u8bit <> RESULT_U8BIT then 963 failed := true; 964 if trunc(global_s32real) <> trunc(RESULT_S32REAL) then 965 failed:=true; 966 proc_value_s64real_mixed(byte(NOT RESULT_U8BIT),gets64real,RESULT_U8BIT); 967 if value_u8bit <> RESULT_U8BIT then 968 failed := true; 969 if trunc(global_s64real) <> trunc(RESULT_S64REAL) then 970 failed:=true; 971 if failed then 972 fail 973 else 974 WriteLn('Passed!'); 975 976 977 { LOC_MEM, LOC_REFERENCE orddef } 978 clear_globals; 979 clear_values; 980 value_u8bit := RESULT_U8BIT; 981 value_u16bit := RESULT_U16BIT; 982 value_s32bit := RESULT_S32BIT; 983{$ifndef tp} 984 value_s64bit := RESULT_S64BIT; 985{$endif} 986 value_s32real := RESULT_S32REAL; 987 value_s64real := RESULT_S64REAL; 988 989 failed:=false; 990 991 { LOC_REFERENCE } 992 write('Mixed value parameter test (src : LOC_REFERENCE (orddef/enumdef)))...'); 993 proc_value_u8bit_mixed(byte(NOT RESULT_U8BIT),value_u8bit, RESULT_U8BIT); 994 if global_u8bit <> RESULT_U8BIT then 995 failed:=true; 996 if value_u8bit <> RESULT_U8BIT then 997 failed := true; 998 proc_value_u16bit_mixed(byte(NOT RESULT_U8BIT),value_u16bit, RESULT_U8BIT); 999 if global_u16bit <> RESULT_U16BIT then 1000 failed:=true; 1001 if value_u8bit <> RESULT_U8BIT then 1002 failed := true; 1003 proc_value_s32bit_mixed(byte(NOT RESULT_U8BIT),value_s32bit, RESULT_U8BIT); 1004 if global_s32bit <> RESULT_S32BIT then 1005 failed:=true; 1006 if value_u8bit <> RESULT_U8BIT then 1007 failed := true; 1008{$ifndef tp} 1009 proc_value_s64bit_mixed(byte(NOT RESULT_U8BIT), value_s64bit, RESULT_U8BIT); 1010 if global_s64bit <> RESULT_S64BIT then 1011 failed:=true; 1012{$endif} 1013 if value_u8bit <> RESULT_U8BIT then 1014 failed := true; 1015 1016 if failed then 1017 fail 1018 else 1019 WriteLn('Passed!'); 1020 1021 1022 { LOC_REFERENCE } 1023 clear_globals; 1024 failed:=false; 1025 write('Mixed value parameter test (src : LOC_REFERENCE (floatdef))...'); 1026 proc_value_s32real_mixed(byte(NOT RESULT_U8BIT), value_s32real, RESULT_U8BIT); 1027 if trunc(global_s32real) <> trunc(RESULT_S32REAL) then 1028 failed:=true; 1029 if value_u8bit <> RESULT_U8BIT then 1030 failed := true; 1031 proc_value_s64real_mixed(byte(NOT RESULT_U8BIT), value_s64real, RESULT_U8BIT); 1032 if trunc(global_s64real) <> trunc(RESULT_S64REAL) then 1033 failed:=true; 1034 if value_u8bit <> RESULT_U8BIT then 1035 failed := true; 1036 1037 if failed then 1038 fail 1039 else 1040 WriteLn('Passed!'); 1041 1042 1043 1044 write('Mixed value parameter test (src : LOC_REFERENCE (pointer))...'); 1045 clear_globals; 1046 clear_values; 1047 failed:=false; 1048 value_ptr := RESULT_PCHAR; 1049 proc_value_pointerdef_mixed(byte(NOT RESULT_U8BIT), value_ptr, RESULT_U8BIT); 1050 if global_ptr <> value_ptr then 1051 failed := true; 1052 if value_u8bit <> RESULT_U8BIT then 1053 failed := true; 1054 1055 1056 value_proc := {$ifndef tp}@{$endif}testprocedure; 1057 proc_value_procvardef_mixed(byte(NOT RESULT_U8BIT), value_proc, RESULT_U8BIT); 1058 if {$ifndef fpc}@{$endif}value_proc <> {$ifndef fpc}@{$endif}global_proc then 1059 failed := true; 1060 1061{$ifndef tp} 1062 value_class := tclass1.create; 1063 proc_value_classrefdef_mixed(byte(NOT RESULT_U8BIT), value_class, RESULT_U8BIT); 1064 if value_class <> global_class then 1065 failed := true; 1066 if value_u8bit <> RESULT_U8BIT then 1067 failed := true; 1068 value_class.destroy; 1069{$endif} 1070 if failed then 1071 fail 1072 else 1073 WriteLn('Passed!'); 1074 1075 1076 1077 1078 { LOC_REFERENCE } 1079 clear_globals; 1080 clear_values; 1081 failed:=false; 1082 value_u8bit := 0; 1083 write('Mixed value parameter test (src : LOC_FLAGS (orddef)))...'); 1084 proc_value_bool8bit_mixed(byte(NOT RESULT_U8BIT), value_u8bit = 0, RESULT_U8BIT); 1085 if global_u8bit <> RESULT_BOOL8BIT then 1086 failed:=true; 1087 if value_u8bit <> RESULT_U8BIT then 1088 failed := true; 1089{* IMPOSSIBLE TO GENERATE LOC_FLAGS WITH SIZE <> S_B ON VERSION 1.0.x 1090 proc_value_bool16bit(value_s64bit < 0); 1091 if global_u16bit <> RESULT_BOOL16BIT then 1092 failed:=true; 1093 proc_value_bool32bit(bool1 and bool2); 1094 if global_s32bit <> RESULT_BOOL32BIT then 1095 failed:=true;*} 1096 if failed then 1097 fail 1098 else 1099 WriteLn('Passed!'); 1100 1101 1102 1103{$ifndef tp} 1104 clear_globals; 1105 clear_values; 1106 failed:=false; 1107 write('Mixed value parameter test (src : LOC_JUMP (orddef)))...'); 1108 proc_value_bool8bit_mixed(byte(NOT RESULT_U8BIT), value_s64bit = 0, RESULT_U8BIT); 1109 if global_u8bit <> RESULT_BOOL8BIT then 1110 failed:=true; 1111 if value_u8bit <> RESULT_U8BIT then 1112 failed := true; 1113{* IMPOSSIBLE TO GENERATE LOC_JUMP WITH SIZE <> S_B ON VERSION 1.0.x 1114 proc_value_bool16bit(value_s64bit < 0); 1115 if global_u16bit <> RESULT_BOOL16BIT then 1116 failed:=true; 1117 proc_value_bool32bit(bool1 and bool2); 1118 if global_s32bit <> RESULT_BOOL32BIT then 1119 failed:=true;*} 1120 if failed then 1121 fail 1122 else 1123 WriteLn('Passed!'); 1124{$endif} 1125 1126 { arraydef, 1127 recorddef, 1128 objectdef, 1129 stringdef, 1130 setdef : all considered the same by code generator. 1131 } 1132 write('Mixed value parameter test (src : LOC_REFERENCE (recorddef)))...'); 1133 clear_globals; 1134 clear_values; 1135 failed := false; 1136 1137 value_smallrec.b := RESULT_U8BIT; 1138 value_smallrec.w := RESULT_U16BIT; 1139 proc_value_smallrecord_mixed(byte(NOT RESULT_U8BIT), value_smallrec, RESULT_U8BIT); 1140 if global_u8bit <> RESULT_U8BIT then 1141 failed := true; 1142 if value_u8bit <> RESULT_U8BIT then 1143 failed := true; 1144 1145 clear_globals; 1146 clear_values; 1147 fillchar(value_largerec,sizeof(value_largerec),RESULT_U8BIT); 1148 proc_value_largerecord_mixed(byte(NOT RESULT_U8BIT), value_largerec, RESULT_U8BIT); 1149 if global_u8bit <> RESULT_U8BIT then 1150 failed := true; 1151 if value_u8bit <> RESULT_U8BIT then 1152 failed := true; 1153 1154 if failed then 1155 fail 1156 else 1157 WriteLn('Passed!'); 1158 1159 1160 1161 write('Mixed value parameter test (src : LOC_REFERENCE (setdef)))...'); 1162 clear_globals; 1163 clear_values; 1164 failed := false; 1165 1166 value_smallset := [A_A,A_D]; 1167 proc_value_smallset_mixed(byte(NOT RESULT_U8BIT), value_smallset, RESULT_U8BIT); 1168 if global_u8bit <> RESULT_U8BIT then 1169 failed := true; 1170 if value_u8bit <> RESULT_U8BIT then 1171 failed := true; 1172 1173 clear_globals; 1174 clear_values; 1175 value_largeset := ['I']; 1176 proc_value_largeset_mixed(byte(NOT RESULT_U8BIT), value_largeset, RESULT_U8BIT); 1177 if global_u8bit <> RESULT_U8BIT then 1178 failed := true; 1179 if value_u8bit <> RESULT_U8BIT then 1180 failed := true; 1181 1182 if failed then 1183 fail 1184 else 1185 WriteLn('Passed!'); 1186 1187 1188 1189 1190 1191 write('Mixed value parameter test (src : LOC_REFERENCE (stringdef)))...'); 1192 clear_globals; 1193 clear_values; 1194 failed := false; 1195 value_smallstring := RESULT_SMALLSTRING; 1196 1197 proc_value_smallstring_mixed(byte(NOT RESULT_U8BIT), value_smallstring, RESULT_U8BIT); 1198 if global_u8bit <> RESULT_U8BIT then 1199 failed := true; 1200 if value_u8bit <> RESULT_U8BIT then 1201 failed := true; 1202 1203 clear_globals; 1204 clear_values; 1205 value_bigstring := RESULT_BIGSTRING; 1206 proc_value_bigstring_mixed(byte(NOT RESULT_U8BIT), value_bigstring, RESULT_U8BIT); 1207 if global_u8bit <> RESULT_U8BIT then 1208 failed := true; 1209 if value_u8bit <> RESULT_U8BIT then 1210 failed := true; 1211 1212 if failed then 1213 fail 1214 else 1215 WriteLn('Passed!'); 1216 1217 1218 1219 { open array by value with cdecl modifier!!!!!!!!!!!!!!!!!!!!!!!!!!!} 1220 { DON'T KNOW WHY/HOW TO TEST!!!!! } 1221 1222 1223 write('Mixed value parameter test (src : LOC_REFERENCE (arraydef)))...'); 1224 1225 clear_globals; 1226 clear_values; 1227 failed:=false; 1228 1229 fillchar(value_smallarray,sizeof(value_smallarray),#0); 1230 value_smallarray[SMALL_INDEX] := RESULT_U8BIT; 1231 proc_value_smallarray_mixed(byte(NOT RESULT_U8BIT), value_smallarray, RESULT_U8BIT); 1232 if global_u8bit <> RESULT_U8BIT then 1233 failed := true; 1234 if value_u8bit <> RESULT_U8BIT then 1235 failed := true; 1236 1237 clear_globals; 1238 clear_values; 1239 1240 fillchar(value_smallarray,sizeof(value_smallarray),#0); 1241 value_smallarray[SMALL_INDEX] := RESULT_U8BIT; 1242 proc_value_smallarray_open_mixed(byte(NOT RESULT_U8BIT), value_smallarray, RESULT_U8BIT); 1243 if global_u8bit <> RESULT_U8BIT then 1244 failed := true; 1245 if value_u8bit <> RESULT_U8BIT then 1246 failed := true; 1247 1248{$ifndef tp} 1249 clear_globals; 1250 clear_values; 1251 1252 value_u8bit := RESULT_U8BIT; 1253 value_ptr := RESULT_PCHAR; 1254 value_s64bit := RESULT_S64BIT; 1255 value_smallstring := RESULT_SMALLSTRING; 1256 value_class := tclass1.create; 1257 value_boolean := RESULT_BOOLEAN; 1258 value_char := RESULT_CHAR; 1259 value_s64real:=RESULT_S64REAL; 1260 proc_value_smallarray_const_1_mixed(byte(NOT RESULT_U8BIT), [value_u8bit,value_ptr,value_s64bit,value_char, 1261 value_smallstring,value_s64real,value_boolean,value_class], 1262 RESULT_U8BIT); 1263 if value_u8bit <> RESULT_U8BIT then 1264 failed := true; 1265 1266 if global_u8bit <> RESULT_U8BIT then 1267 failed := true; 1268 1269 if global_char <> RESULT_CHAR then 1270 failed := true; 1271 if global_boolean <> RESULT_BOOLEAN then 1272 failed:=true; 1273 if trunc(global_s64real) <> trunc(RESULT_S64REAL) then 1274 failed := true; 1275 if global_bigstring <> RESULT_SMALLSTRING then 1276 failed := true; 1277 if global_ptr <> value_ptr then 1278 failed := true; 1279{ if value_class <> global_class then 1280 failed := true;!!!!!!!!!!!!!!!!!!!!} 1281 if global_s64bit <> RESULT_S64BIT then 1282 failed := true; 1283 if assigned(value_class) then 1284 value_class.destroy; 1285 1286 global_u8bit := 0; 1287 proc_value_smallarray_const_2_mixed(byte(NOT RESULT_U8BIT), [], RESULT_U8BIT); 1288 if global_u8bit <> RESULT_U8BIT then 1289 failed := true; 1290 if value_u8bit <> RESULT_U8BIT then 1291 failed := true; 1292{$endif} 1293 1294 if failed then 1295 fail 1296 else 1297 WriteLn('Passed!'); 1298 1299end. 1300