1{ 2 This file is part of the Free Pascal run time library. 3 Copyright (c) 2005-2006 by the Free Pascal development team 4 and Gehard Scholz 5 6 It contains the Free Pascal BCD implementation 7 8 See the file COPYING.FPC, included in this distribution, 9 for details about the copyright. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS for A PARTICULAR PURPOSE. 14 15 **********************************************************************} 16{ "Programming is the time between two bugs" } 17{ (last words of the unknown programmer) } 18 19(* this program was a good test for the compiler: some bugs have been found. 20 21 1. WITH in inline funcs produces a compiler error AFTER producing an .exe file 22 (was already known; I didn't see it in the bug list) 23 24 2. macro names were checked for being a keyword, even when starting with 25 an '_' (produces range check when compiler is compiled with { $r+ }-mode 26 fixed. 27 28 3. { $define program } was not possible in { $macro on } mode 29 (keywords not allowed: doesn't make sense here) 30 fixed. 31 32 4. the Inc/Dec ( unsigned, signed ) problem (has been similar in the 33 bug list already) 34 35 5. when the result of an overloaded (inline) operator is ABSOLUTEd: 36 compiler error 200110205 37 happens only when operator is defined in a unit. 38 39 6. two range check errors in scanner.pas 40 a) array subscripting 41 b) value out ouf range 42*) 43 44{ $define debug_version} 45 46// Dont use s+ (Stack checking on) because it crashes libraries, see bug 21208 47{$r+,q+,s-} 48 49{$mode objfpc} 50{$h-} 51 52{$inline on} 53 54{$macro on} 55 56{$define BCDMaxDigits := 64 } { should be even } 57 58{ the next defines must be defined by hand, 59 unless someone shows me a way how to to it with macros } 60 61{$define BCDgr4} { define this if MCDMaxDigits is greater 4, else undefine! } 62{$define BCDgr9} { define this if MCDMaxDigits is greater 9, else undefine! } 63{$define BCDgr18} { define this if MCDMaxDigits is greater 18, else undefine! } 64{ $define BCDgr64} { define this if MCDMaxDigits is greater 64, else undefine! } 65{ $define BCDgr180} { define this if MCDMaxDigits is greater 180, else undefine! } 66 67{$ifdef BCDgr4} 68 {$hint BCD Digits > 4} 69{$endif} 70 71{$ifdef BCDgr9} 72 {$hint BCD Digits > 9} 73{$endif} 74 75{$ifdef BCDgr18} 76 {$hint BCD Digits > 18} 77{$endif} 78 79{$ifdef BCDgr64} 80 {$hint BCD Digits > 64} 81{$endif} 82 83{$ifdef BCDgr180} 84 {$hint BCD Digits > 180} 85{$endif} 86 87{$ifndef NO_SMART_LINK} 88{ $smartlink on} 89{$endif} 90 91{$define some_packed} { enable this to keep some local structures PACKED } 92 93{ $define as_object} { to define the tBCD record as object instead; 94 fields then are private } 95 { not done yet! } 96 97{$define additional_routines} { to create additional routines and operators } 98 99(* only define one of them! *) 100{ $define integ32} 101{$define integ64} 102 103(* only define one of them! *) 104{ $define real8} 105{$define real10} 106 107{check} 108{$ifndef integ32} 109 {$ifndef integ64} 110 {$define integ64} 111 {$endif} 112{$endif} 113 114{$ifdef integ32} 115 {$ifdef integ64} 116 {$undef integ32} 117 {$endif} 118{$endif} 119 120{check} 121{$ifndef real8} 122 {$ifndef real10} 123 {$define real8} 124 {$endif} 125{$endif} 126 127{$ifdef real8} 128 {$ifdef real10} 129 {$undef real10} 130 {$endif} 131{$endif} 132 133{$ifdef some_packed} 134 {$define maybe_packed := packed} 135{$else} 136 {$define maybe_packed := (**)} 137{$endif} 138 139UNIT FmtBCD; 140 141INTERFACE 142 143 USES 144 SysUtils, 145 Variants; 146 147 const 148 MaxStringDigits = 100; { not used ! } 149 _NoDecimal = -255; { not used ! } 150 _DefaultDecimals = 10; { not used ! } 151 152 { From DB.pas } 153 { Max supported by Midas } { must be EVEN } 154 MaxFmtBCDFractionSize = BCDMaxDigits + Ord ( Odd ( BCDMaxDigits ) ); 155 { Max supported by Midas } 156 MaxFmtBCDDigits = 32; { not used ! } 157 DefaultFmtBCDScale = 6; { not used ! } 158 MaxBCDPrecision = 18; { not used ! } 159 MaxBCDScale = 4; { not used ! } 160 161{$ifdef BCDgr64} 162{ $fatal big 1} 163 {$define bigger_BCD} { must be defined 164 if MaxFmtBCDFractionSize > 64 } 165 { not usable in the moment } 166{$endif} 167 168{$ifdef BCDgr180} 169{ $fatal big 2} 170 type 171 FmtBCDStringtype = AnsiString; 172 {$define use_Ansistring} 173{$else} 174 type 175 FmtBCDStringtype = string [ 255 ]; 176 {$undef use_Ansistring} 177{$endif} 178 179{$ifdef use_ansistring} 180 {$hint ansi} 181{$else} 182 {$hint -ansi} 183{$endif} 184 185{$ifdef integ32} 186 {$define myInttype := LongInt} 187{$endif} 188{$ifdef integ64} 189 {$define myInttype := int64} 190{$endif} 191 192{$ifndef FPUNONE} 193{$ifdef real8} 194 {$define myRealtype := double} 195{$endif} 196{$ifdef real10} 197 {$define myRealtype := extended} 198{$endif} 199{$endif} 200 201{$ifdef SUPPORT_COMP} 202 {$define comproutines} 203{$endif SUPPORT_COMP} 204 205{$define __low_Fraction := 0 } 206{$define __high_Fraction := ( ( MaxFmtBCDFractionSize DIV 2 ) - 1 ) } 207 208 type 209 pBCD = ^ tBCD; 210 tBCD = packed {$ifdef as_object} OBJECT {$else} record {$endif} 211 {$ifdef as_object} PRIVATE {$endif} 212 Precision : 0..maxfmtbcdfractionsize; { 1 (joke?)..64 } 213{$ifndef bigger_BCD} 214 SignSpecialPlaces : Byte; { Sign:1, Special:1, Places:6 } 215{$else} 216 Negativ : Boolean; 217{ 218 Special : Boolean; 219} 220 Places : 0..maxfmtbcdfractionsize - 1; 221{$endif} 222 Fraction : packed array [ __low_Fraction..__high_Fraction ] of Byte; 223 { BCD Nibbles, 00..99 per Byte, high Nibble 1st } 224 end; 225 226{ Exception classes } 227 type 228 eBCDException = CLASS ( Exception ); 229 eBCDOverflowException = CLASS ( eBCDException ); 230 eBCDNotImplementedException = CLASS ( eBCDException ); 231 232 233{ Utility functions for TBCD access } 234 235 function BCDPrecision ( const BCD : tBCD ) : Word; Inline; 236 237 function BCDScale ( const BCD : tBCD ) : Word; Inline; 238 239 function IsBCDNegative ( const BCD : tBCD ) : Boolean; Inline; 240 241{ BCD Arithmetic} 242 243 procedure BCDNegate ( var BCD : tBCD ); Inline; 244 245{ !!!!!!!!!! most routines are intentionally NOT inline !!!!!!!!!! } 246 247{ Returns True if successful, False if Int Digits needed to be truncated } 248 function NormalizeBCD ( const InBCD : tBCD; 249 var OutBCD : tBCD; 250 const Precision, 251 Places : Integer ) : Boolean; 252 253 procedure BCDAdd ( const BCDin1, 254 BCDin2 : tBCD; 255 var BCDout : tBCD ); 256 257 procedure BCDSubtract ( const BCDin1, 258 BCDin2 : tBCD; 259 var BCDout : tBCD ); 260 261 procedure BCDMultiply ( const BCDin1, 262 BCDin2 : tBCD; 263 var BCDout : tBCD ); 264 265{$ifndef FPUNONE} 266 procedure BCDMultiply ( const BCDIn : tBCD; 267 const DoubleIn : myRealtype; 268 var BCDout : tBCD ); Inline; 269{$endif} 270 271 procedure BCDMultiply ( const BCDIn : tBCD; 272 const StringIn : FmtBCDStringtype; 273 var BCDout : tBCD ); Inline; 274 275{ !!! params changed to const, shouldn't give a problem } 276 procedure BCDMultiply ( const StringIn1, 277 StringIn2 : FmtBCDStringtype; 278 var BCDout : tBCD ); Inline; 279 280 procedure BCDDivide ( const Dividend, 281 Divisor : tBCD; 282 var BCDout : tBCD ); 283 284{$ifndef FPUNONE} 285 procedure BCDDivide ( const Dividend : tBCD; 286 const Divisor : myRealtype; 287 var BCDout : tBCD ); Inline; 288{$endif} 289 290 procedure BCDDivide ( const Dividend : tBCD; 291 const Divisor : FmtBCDStringtype; 292 var BCDout : tBCD ); Inline; 293 294{ !!! params changed to const, shouldn't give a problem } 295 procedure BCDDivide ( const Dividend, 296 Divisor : FmtBCDStringtype; 297 var BCDout : tBCD ); Inline; 298 299{ TBCD variant creation utils } 300 procedure VarFmtBCDCreate ( var aDest : Variant; 301 const aBCD : tBCD ); 302 303 function VarFmtBCDCreate : Variant; 304 305 function VarFmtBCDCreate ( const aValue : FmtBCDStringtype; 306 Precision, 307 Scale : Word ) : Variant; 308 309{$ifndef FPUNONE} 310 function VarFmtBCDCreate ( const aValue : myRealtype; 311 Precision : Word = 18; 312 Scale : Word = 4 ) : Variant; 313{$endif} 314 315 function VarFmtBCDCreate ( const aBCD : tBCD ) : Variant; 316 317 function VarIsFmtBCD ( const aValue : Variant ) : Boolean; 318 319 function VarFmtBCD : TVartype; 320 321{ Convert string/Double/Integer to BCD struct } 322 function StrToBCD ( const aValue : FmtBCDStringtype ) : tBCD; 323 324 function StrToBCD ( const aValue : FmtBCDStringtype; 325 const Format : TFormatSettings ) : tBCD; 326 327 function TryStrToBCD ( const aValue : FmtBCDStringtype; 328 var BCD : tBCD ) : Boolean; 329 330 function TryStrToBCD ( const aValue : FmtBCDStringtype; 331 var BCD : tBCD; 332 const Format : TFormatSettings) : Boolean; 333 334{$ifndef FPUNONE} 335 function DoubleToBCD ( const aValue : myRealtype ) : tBCD; Inline; 336 337 procedure DoubleToBCD ( const aValue : myRealtype; 338 var BCD : tBCD ); 339{$endif} 340 341 function IntegerToBCD ( const aValue : myInttype ) : tBCD; 342 343 function VarToBCD ( const aValue : Variant ) : tBCD; 344 345{ From DB.pas } 346 function CurrToBCD ( const Curr : currency; 347 var BCD : tBCD; 348 Precision : Integer = 32; 349 Decimals : Integer = 4 ) : Boolean; 350 351{ Convert BCD struct to string/Double/Integer } 352 function BCDToStr ( const BCD : tBCD ) : FmtBCDStringtype; 353 354 function BCDToStr ( const BCD : tBCD; 355 const Format : TFormatSettings ) : FmtBCDStringtype; 356 357{$ifndef FPUNONE} 358 function BCDToDouble ( const BCD : tBCD ) : myRealtype; 359{$endif} 360 361 function BCDToInteger ( const BCD : tBCD; 362 Truncate : Boolean = False ) : myInttype; 363 364{ From DB.pas } 365 function BCDToCurr ( const BCD : tBCD; 366 var Curr : currency ) : Boolean; 367 368{ Formatting BCD as string } 369 function BCDToStrF ( const BCD : tBCD; 370 Format : TFloatFormat; 371 const Precision, 372 Digits : Integer ) : FmtBCDStringtype; 373 374 function FormatBCD ( const Format : string; 375 BCD : tBCD ) : FmtBCDStringtype; 376 377{ returns -1 if BCD1 < BCD2, 0 if BCD1 = BCD2, 1 if BCD1 > BCD2 } 378 function BCDCompare ( const BCD1, 379 BCD2 : tBCD ) : Integer; 380 381{$ifdef additional_routines} 382 383 function CurrToBCD ( const Curr : currency ) : tBCD; Inline; 384 385{$ifdef comproutines} 386 function CompToBCD ( const Curr : Comp ) : tBCD; Inline; 387 388 function BCDToComp ( const BCD : tBCD ) : Comp; Inline; 389{$endif} 390 391 procedure BCDAdd ( const BCDIn : tBCD; 392 const IntIn : myInttype; 393 var BCDout : tBCD ); 394 395 procedure BCDAdd ( const IntIn : myInttype; 396 const BCDIn : tBCD; 397 var BCDout : tBCD ); Inline; 398 399{$ifndef FPUNONE} 400 procedure BCDAdd ( const BCDIn : tBCD; 401 const DoubleIn : myRealtype; 402 var BCDout : tBCD ); Inline; 403 404 procedure BCDAdd ( const DoubleIn : myRealtype; 405 const BCDIn : tBCD; 406 var BCDout : tBCD ); Inline; 407{$endif} 408 409 procedure BCDAdd ( const BCDIn : tBCD; 410 const Currin : currency; 411 var BCDout : tBCD ); Inline; 412 413 procedure BCDAdd ( const Currin : currency; 414 const BCDIn : tBCD; 415 var BCDout : tBCD ); Inline; 416 417{$ifdef comproutines} 418 procedure BCDAdd ( const BCDIn : tBCD; 419 const Compin : Comp; 420 var BCDout : tBCD ); Inline; 421 422 procedure BCDAdd ( const Compin : Comp; 423 const BCDIn : tBCD; 424 var BCDout : tBCD ); Inline; 425{$endif} 426 427 procedure BCDAdd ( const BCDIn : tBCD; 428 const StringIn : FmtBCDStringtype; 429 var BCDout : tBCD ); Inline; 430 431 procedure BCDAdd ( const StringIn : FmtBCDStringtype; 432 const BCDIn : tBCD; 433 var BCDout : tBCD ); Inline; 434 435 procedure BCDAdd ( const StringIn1, 436 StringIn2 : FmtBCDStringtype; 437 var BCDout : tBCD ); Inline; 438 439 procedure BCDSubtract ( const BCDIn : tBCD; 440 const IntIn : myInttype; 441 var BCDout : tBCD ); 442 443 procedure BCDSubtract ( const IntIn : myInttype; 444 const BCDIn : tBCD; 445 var BCDout : tBCD ); Inline; 446 447{$ifndef FPUNONE} 448 procedure BCDSubtract ( const BCDIn : tBCD; 449 const DoubleIn : myRealtype; 450 var BCDout : tBCD ); Inline; 451 452 procedure BCDSubtract ( const DoubleIn : myRealtype; 453 const BCDIn : tBCD; 454 var BCDout : tBCD ); Inline; 455{$endif} 456 457 procedure BCDSubtract ( const BCDIn : tBCD; 458 const Currin : currency; 459 var BCDout : tBCD ); Inline; 460 461 procedure BCDSubtract ( const Currin : currency; 462 const BCDIn : tBCD; 463 var BCDout : tBCD ); Inline; 464 465{$ifdef comproutines} 466 procedure BCDSubtract ( const BCDIn : tBCD; 467 const Compin : Comp; 468 var BCDout : tBCD ); Inline; 469 470 procedure BCDSubtract ( const Compin : Comp; 471 const BCDIn : tBCD; 472 var BCDout : tBCD ); Inline; 473{$endif} 474 475 procedure BCDSubtract ( const BCDIn : tBCD; 476 const StringIn : FmtBCDStringtype; 477 var BCDout : tBCD ); Inline; 478 479 procedure BCDSubtract ( const StringIn : FmtBCDStringtype; 480 const BCDIn : tBCD; 481 var BCDout : tBCD ); Inline; 482 483 procedure BCDSubtract ( const StringIn1, 484 StringIn2 : FmtBCDStringtype; 485 var BCDout : tBCD ); Inline; 486 487 procedure BCDMultiply ( const BCDIn : tBCD; 488 const IntIn : myInttype; 489 var BCDout : tBCD ); 490 491 procedure BCDMultiply ( const IntIn : myInttype; 492 const BCDIn : tBCD; 493 var BCDout : tBCD ); Inline; 494 495{$ifndef FPUNONE} 496 procedure BCDMultiply ( const DoubleIn : myRealtype; 497 const BCDIn : tBCD; 498 var BCDout : tBCD ); Inline; 499{$endif} 500 501 procedure BCDMultiply ( const BCDIn : tBCD; 502 const Currin : currency; 503 var BCDout : tBCD ); Inline; 504 505 procedure BCDMultiply ( const Currin : currency; 506 const BCDIn : tBCD; 507 var BCDout : tBCD ); Inline; 508 509{$ifdef comproutines} 510 procedure BCDMultiply ( const BCDIn : tBCD; 511 const Compin : Comp; 512 var BCDout : tBCD ); Inline; 513 514 procedure BCDMultiply ( const Compin : Comp; 515 const BCDIn : tBCD; 516 var BCDout : tBCD ); Inline; 517{$endif} 518 519 procedure BCDMultiply ( const StringIn : FmtBCDStringtype; 520 const BCDIn : tBCD; 521 var BCDout : tBCD ); Inline; 522 523 procedure BCDDivide ( const Dividend : tBCD; 524 const Divisor : myInttype; 525 var BCDout : tBCD ); Inline; 526 527 procedure BCDDivide ( const Dividend : myInttype; 528 const Divisor : tBCD; 529 var BCDout : tBCD ); Inline; 530 531{$ifndef FPUNONE} 532 procedure BCDDivide ( const Dividend : myRealtype; 533 const Divisor : tBCD; 534 var BCDout : tBCD ); Inline; 535{$endif} 536 537 procedure BCDDivide ( const BCDIn : tBCD; 538 const Currin : currency; 539 var BCDout : tBCD ); Inline; 540 541 procedure BCDDivide ( const Currin : currency; 542 const BCDIn : tBCD; 543 var BCDout : tBCD ); Inline; 544 545{$ifdef comproutines} 546 procedure BCDDivide ( const BCDIn : tBCD; 547 const Compin : Comp; 548 var BCDout : tBCD ); Inline; 549 550 procedure BCDDivide ( const Compin : Comp; 551 const BCDIn : tBCD; 552 var BCDout : tBCD ); Inline; 553{$endif} 554 555 procedure BCDDivide ( const Dividend : FmtBCDStringtype; 556 const Divisor : tBCD; 557 var BCDout : tBCD ); Inline; 558 559 operator = ( const BCD1, 560 BCD2 : tBCD ) z : Boolean; Inline; 561 562 operator < ( const BCD1, 563 BCD2 : tBCD ) z : Boolean; Inline; 564 565 operator > ( const BCD1, 566 BCD2 : tBCD ) z : Boolean; Inline; 567 568 operator <= ( const BCD1, 569 BCD2 : tBCD ) z : Boolean; Inline; 570 operator >= ( const BCD1, 571 BCD2 : tBCD ) z : Boolean; Inline; 572 573(* ######################## not allowed: why? 574 operator + ( const BCD : tBCD ) z : tBCD; make_Inline 575##################################################### *) 576 577 operator - ( const BCD : tBCD ) z : tBCD; Inline; 578 579 operator + ( const BCD1, 580 BCD2 : tBCD ) z : tBCD; Inline; 581 582 operator + ( const BCD : tBCD; 583 const i : myInttype ) z : tBCD; Inline; 584 585 operator + ( const i : myInttype; 586 const BCD : tBCD ) z : tBCD; Inline; 587 588{$ifndef FPUNONE} 589 operator + ( const BCD : tBCD; 590 const r : myRealtype ) z : tBCD; Inline; 591 592 operator + ( const r : myRealtype; 593 const BCD : tBCD ) z : tBCD; Inline; 594{$endif} 595 596 operator + ( const BCD : tBCD; 597 const c : currency ) z : tBCD; Inline; 598 599 operator + ( const c : currency; 600 const BCD : tBCD ) z : tBCD; Inline; 601 602{$ifdef comproutines} 603 operator + ( const BCD : tBCD; 604 const c : Comp ) z : tBCD; Inline; 605 606 operator + ( const c : Comp; 607 const BCD : tBCD ) z : tBCD; Inline; 608{$endif} 609 610 operator + ( const BCD : tBCD; 611 const s : FmtBCDStringtype ) z : tBCD; Inline; 612 613 operator + ( const s : FmtBCDStringtype; 614 const BCD : tBCD ) z : tBCD; Inline; 615 616 operator - ( const BCD1, 617 BCD2 : tBCD ) z : tBCD; Inline; 618 619 operator - ( const BCD : tBCD; 620 const i : myInttype ) z : tBCD; Inline; 621 622 operator - ( const i : myInttype; 623 const BCD : tBCD ) z : tBCD; Inline; 624 625{$ifndef FPUNONE} 626 operator - ( const BCD : tBCD; 627 const r : myRealtype ) z : tBCD; Inline; 628 629 operator - ( const r : myRealtype; 630 const BCD : tBCD ) z : tBCD; Inline; 631{$endif} 632 633 operator - ( const BCD : tBCD; 634 const c : currency ) z : tBCD; Inline; 635 636 operator - ( const c : currency; 637 const BCD : tBCD ) z : tBCD; Inline; 638 639{$ifdef comproutines} 640 operator - ( const BCD : tBCD; 641 const c : Comp ) z : tBCD; Inline; 642 643 operator - ( const c : Comp; 644 const BCD : tBCD ) z : tBCD; Inline; 645{$endif} 646 647 operator - ( const BCD : tBCD; 648 const s : FmtBCDStringtype ) z : tBCD; Inline; 649 650 operator - ( const s : FmtBCDStringtype; 651 const BCD : tBCD ) z : tBCD; Inline; 652 653 operator * ( const BCD1, 654 BCD2 : tBCD ) z : tBCD; Inline; 655 656 operator * ( const BCD : tBCD; 657 const i : myInttype ) z : tBCD; Inline; 658 659 operator * ( const i : myInttype; 660 const BCD : tBCD ) z : tBCD; Inline; 661 662{$ifndef FPUNONE} 663 operator * ( const BCD : tBCD; 664 const r : myRealtype ) z : tBCD; Inline; 665 666 operator * ( const r : myRealtype; 667 const BCD : tBCD ) z : tBCD; Inline; 668{$endif} 669 670 operator * ( const BCD : tBCD; 671 const c : currency ) z : tBCD; Inline; 672 673 operator * ( const c : currency; 674 const BCD : tBCD ) z : tBCD; Inline; 675 676{$ifdef comproutines} 677 operator * ( const BCD : tBCD; 678 const c : Comp ) z : tBCD; Inline; 679 680 operator * ( const c : Comp; 681 const BCD : tBCD ) z : tBCD; Inline; 682{$endif} 683 684 operator * ( const BCD : tBCD; 685 const s : FmtBCDStringtype ) z : tBCD; Inline; 686 687 operator * ( const s : FmtBCDStringtype; 688 const BCD : tBCD ) z : tBCD; Inline; 689 690 operator / ( const BCD1, 691 BCD2 : tBCD ) z : tBCD; Inline; 692 693 operator / ( const BCD : tBCD; 694 const i : myInttype ) z : tBCD; Inline; 695 696 operator / ( const i : myInttype; 697 const BCD : tBCD ) z : tBCD; Inline; 698 699{$ifndef FPUNONE} 700 operator / ( const BCD : tBCD; 701 const r : myRealtype ) z : tBCD; Inline; 702 703 operator / ( const r : myRealtype; 704 const BCD : tBCD ) z : tBCD; Inline; 705{$endif} 706 707 operator / ( const BCD : tBCD; 708 const c : currency ) z : tBCD; Inline; 709 710 operator / ( const c : currency; 711 const BCD : tBCD ) z : tBCD; Inline; 712 713{$ifdef comproutines} 714 operator / ( const BCD : tBCD; 715 const c : Comp ) z : tBCD; Inline; 716 717 operator / ( const c : Comp; 718 const BCD : tBCD ) z : tBCD; Inline; 719{$endif} 720 721 operator / ( const BCD : tBCD; 722 const s : FmtBCDStringtype ) z : tBCD; Inline; 723 724 operator / ( const s : FmtBCDStringtype; 725 const BCD : tBCD ) z : tBCD; Inline; 726 727 operator := ( const i : Byte ) z : tBCD; Inline; 728 729 operator := ( const BCD : tBCD ) z : Byte; Inline; 730 731 operator := ( const i : Word ) z : tBCD; Inline; 732 733 operator := ( const BCD : tBCD ) z : Word; Inline; 734 735 operator := ( const i : longword ) z : tBCD; Inline; 736 737 operator := ( const BCD : tBCD ) z : longword; Inline; 738 739{$if declared ( qword ) } 740 operator := ( const i : qword ) z : tBCD; Inline; 741 742 operator := ( const BCD : tBCD ) z : qword; Inline; 743{$endif} 744 745 operator := ( const i : ShortInt ) z : tBCD; Inline; 746 747 operator := ( const BCD : tBCD ) z : ShortInt; Inline; 748 749 operator := ( const i : smallint ) z : tBCD; Inline; 750 751 operator := ( const BCD : tBCD ) z : smallint; Inline; 752 753 operator := ( const i : LongInt ) z : tBCD; Inline; 754 755 operator := ( const BCD : tBCD ) z : LongInt; Inline; 756 757{$if declared ( int64 ) } 758 operator := ( const i : int64 ) z : tBCD; Inline; 759 760 operator := ( const BCD : tBCD ) z : int64; Inline; 761{$endif} 762 763{$ifndef FPUNONE} 764 operator := ( const r : Single ) z : tBCD; Inline; 765 766 operator := ( const BCD : tBCD ) z : Single; Inline; 767 768 operator := ( const r : Double ) z : tBCD; Inline; 769 770 operator := ( const BCD : tBCD ) z : Double; Inline; 771 772{$if sizeof ( extended ) <> sizeof ( double )} 773 operator := ( const r : Extended ) z : tBCD; Inline; 774 775 operator := ( const BCD : tBCD ) z : Extended; Inline; 776{$endif} 777{$endif} 778 779 operator := ( const c : currency ) z : tBCD; Inline; 780 781 operator := ( const BCD : tBCD ) z : currency; Inline; 782 783{$ifdef comproutines} 784 operator := ( const c : Comp ) z : tBCD; Inline; 785 786 operator := ( const BCD : tBCD ) z : Comp; Inline; 787{$endif} 788 789 operator := ( const s : string ) z : tBCD; Inline; 790 791 operator := ( const BCD : tBCD ) z : string; Inline; 792 793 operator := ( const s : AnsiString ) z : tBCD; Inline; 794 795 operator := ( const BCD : tBCD ) z : AnsiString; Inline; 796 797{$endif} 798 799 function __get_null : tBCD; Inline; 800 function __get_zero : tBCD; Inline; 801 function __get_one : tBCD; Inline; 802 803 PROPERTY 804 NullBCD : tBCD Read __get_null; 805 ZeroBCD : tBCD Read __get_zero; 806 OneBCD : tBCD Read __get_one; 807 808//{$define __lo_bh := 1 * ( -( MaxFmtBCDFractionSize * 1 + 2 ) ) } 809//{$define __hi_bh := 1 * ( MaxFmtBCDFractionSize * 1 + 1 ) } 810 811{$define helper_declarations := 812 813 const 814 __lo_bh = -( MaxFmtBCDFractionSize + 2 ); 815 __hi_bh = ( MaxFmtBCDFractionSize + 1 ); 816 817 type 818 tBCD_helper = Maybe_Packed record 819 Prec : {$ifopt r+} 0..( __hi_bh - __lo_bh + 1 ) {$else} Integer {$endif}; 820 Plac : {$ifopt r+} 0..( __hi_bh - __lo_bh + 1 ) {$else} Integer {$endif}; 821 FDig, 822 LDig : {$ifopt r+} __lo_bh..__hi_bh {$else} Integer {$endif}; 823 Singles : Maybe_packed array [ __lo_bh..__hi_bh ] 824 of {$ifopt r+} 0..9 {$else} Byte {$endif}; 825 Neg : Boolean; 826 end; 827 { in the tBCD_helper the bcd is stored for computations, 828 shifted to the right position } 829 830// {$define __lo_bhb := 1 * ( __lo_bh + __lo_bh ) } 831// {$define __hi_bhb := 1 * ( __hi_bh + __hi_bh + 1 ) } 832 const 833 __lo_bhb = __lo_bh + __lo_bh - 1; 834 __hi_bhb = __hi_bh + __hi_bh; 835 836 type 837 tBCD_helper_big = Maybe_Packed record 838 Prec : {$ifopt r+} 0.. ( __hi_bhb - __lo_bhb + 1 ) {$else} Integer {$endif}; 839 Plac : {$ifopt r+} 0.. ( __hi_bhb - __lo_bhb + 1 ) {$else} Integer {$endif}; 840 FDig, 841 LDig : {$ifopt r+} __lo_bhb..__hi_bhb {$else} Integer {$endif}; 842 Singles : Maybe_packed array [ __lo_bhb..__hi_bhb ] 843 of {$ifopt r+} 0 * 0..9 * 9 * Pred ( MaxFmtBCDDigits ) {$else} Integer {$endif}; 844 Neg : Boolean; 845 end; 846} 847 848{$ifdef debug_version} 849 helper_declarations 850 851 procedure unpack_BCD ( const BCD : tBCD; 852 var bh : tBCD_helper ); 853 function pack_BCD ( var bh : tBCD_helper; 854 var BCD : tBCD ) : Boolean; 855 856 procedure dumpBCD ( const v : tBCD ); 857{$endif} 858 859IMPLEMENTATION 860 861 USES 862 classes {$ifopt r+}, sysconst {$endif}; 863 864 type 865 TFMTBcdFactory = CLASS(TPublishableVarianttype) 866 PROTECTED 867 function GetInstance(const v : TVarData): tObject; OVERRIDE; 868 PUBLIC 869 procedure BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp); override; 870 procedure Clear(var V: TVarData); override; 871 procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override; 872 function CompareOp(const Left, Right: TVarData; const Operation: TVarOp): Boolean; override; 873 procedure Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult); override; 874 procedure Cast(var Dest: TVarData; const Source: TVarData); override; 875 procedure CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); override; 876 end; 877 878 TFMTBcdVarData = CLASS(TPersistent) 879 PRIVATE 880 FBcd : tBCD; 881 PUBLIC 882 constructor create; 883 constructor create(const BCD : tBCD); 884 PROPERTY BCD : tBCD Read FBcd Write FBcd; 885 end; 886 887 var 888 NullBCD_ : tBCD; 889 OneBCD_ : tBCD; 890 891 function __get_null : tBCD; Inline; 892 begin 893 __get_null := NullBCD_; 894 end; 895 896 function __get_zero : tBCD; Inline; 897 begin 898 __get_zero := NullBCD_; 899 __get_zero.Precision := 1; 900 end; 901 902 function __get_one : tBCD; Inline; 903 begin 904 __get_one := OneBCD_; 905 end; 906 907 type 908 range_digits = 1..maxfmtbcdfractionsize; 909 range_digits0 = 0..maxfmtbcdfractionsize; 910 range_fracdigits = 0..pred ( MaxFmtBCDFractionSize ); 911 912{$ifopt r+} 913 procedure RangeError; 914 begin 915 raise ERangeError.Create(SRangeError); 916 end; 917{$endif} 918 919{$ifndef debug_version} 920 helper_declarations 921{$endif} 922 923 var 924 null_ : record 925 case Boolean of 926 False: ( bh : tBCD_helper ); 927 True: ( bhb : tBCD_helper_big ); 928 end; 929 930 FMTBcdFactory : TFMTBcdFactory = NIL; 931 932{$ifndef bigger_BCD} 933 const 934 NegBit = 1 SHL 7; 935 SpecialBit = 1 SHL 6; 936 PlacesMask = $ff XOR ( NegBit OR SpecialBit ); 937{$endif} 938 939{$define _select := {$define _when := if {$define _when := end else if } } 940 {$define _then := then begin } 941 {$define _whenother := end else begin } 942 {$define _endselect := end } } 943 944{$ifdef debug_version} 945 procedure dumpBCD ( const v : tBCD ); 946 947 var 948 i, 949 j : Integer; 950 951 const 952 ft : ARRAY [ Boolean ] of Char = ( 'f', 't' ); 953 954 begin 955{$ifndef bigger_BCD} 956 Write ( 'Prec:', v.Precision, ' ', 957 'Neg:', ft[( v.SignSpecialPlaces AND NegBit ) <> 0], ' ', 958 'Special:', ft[( v.SignSpecialPlaces AND SpecialBit ) <> 0], ' ', 959 'Places:', v.SignSpecialPlaces AND PlacesMask, ' ' ); 960{$else} 961 Write ( 'Prec:', v.Precision, ' ', 962 'Neg:', ft[v.Negativ], ' ', 963 'Places:', v.Places, ' ' ); 964{$endif} 965 j := 0; 966 for i := 1 TO v.Precision do 967 if Odd ( i ) 968 then Write ( ( v.Fraction[j] AND $f0 ) SHR 4 ) 969 else begin 970 Write ( v.Fraction[j] AND $0f ); 971 Inc ( j ); 972 end; 973 WriteLn; 974 end; 975 976 procedure dumpbh ( const v : tBCD_helper ); 977 978 var 979 i : Integer; 980 981 const 982 ft : ARRAY [ Boolean ] of Char = ( 'f', 't' ); 983 984 begin 985 Write ( 'Prec:', v.Prec, ' ', 986 'Neg:', ft[v.Neg], ' ', 987 'Places:', v.Plac, ' ', 988 'FDig:', v.FDig, ' ', 989 'LDig:', v.LDig, ' ', 990 'Digits:', v.LDig - v.FDig + 1, ' ' ); 991 for i := v.FDig TO v.LDig do 992 Write ( v.Singles[i] ); 993 WriteLn; 994 end; 995{$endif} 996 997{$if sizeof ( integer ) = 2 } 998 {$ifdef BCDgr4 } 999 var 1000 myMinIntBCD : tBCD; 1001 {$endif} 1002{$else} 1003 {$if sizeof ( integer ) = 4 } 1004 {$ifdef BCDgr9 } 1005 var 1006 myMinIntBCD : tBCD; 1007 {$endif} 1008 {$else} 1009 {$if sizeof ( integer ) = 8 } 1010 {$ifdef BCDgr18 } 1011 var 1012 myMinIntBCD : tBCD; 1013 {$endif} 1014 {$else} 1015 {$fatal You have an interesting integer type! Sorry, not supported} 1016 {$endif} 1017 {$endif} 1018{$endif} 1019 1020 procedure not_implemented; 1021 1022 begin 1023 RAISE eBCDNotImplementedException.create ( 'not implemented' ); 1024 end; 1025 1026 procedure unpack_BCD ( const BCD : tBCD; 1027 var bh : tBCD_helper ); 1028 1029 var 1030 i : {$ifopt r+} __lo_bh + 1 ..__hi_bh {$else} Integer {$endif}; 1031 j : {$ifopt r+} __low_fraction..__high_fraction+1 {$else} Integer {$endif}; 1032 vv : {$ifopt r+} $00..$99 {$else} Integer {$endif}; 1033 1034 begin 1035 bh := null_.bh; 1036 WITH bh, 1037 BCD do 1038 begin 1039 Prec := Precision; 1040 if Prec > 0 1041 then begin 1042{$ifndef bigger_BCD} 1043 Plac := SignSpecialPlaces AND PlacesMask; 1044 Neg := ( SignSpecialPlaces AND NegBit ) <> 0; 1045{$else} 1046 Plac := Places; 1047 Neg := Negativ; 1048{$endif} 1049 LDig := Plac; 1050 FDig := LDig - Prec + 1; 1051 j := 0; 1052 i := FDig; 1053 while i <= LDig do 1054 begin 1055 vv := Fraction[j]; 1056 Singles[i] := ( vv {AND $f0} ) SHR 4; 1057 if i < LDig 1058 then Singles[i+1] := vv AND $0f; 1059 Inc ( j ); 1060 Inc ( i, 2 ); 1061 end; 1062 end; 1063 end; 1064 end; 1065 1066 function pack_BCD ( var bh : tBCD_helper; 1067 var BCD : tBCD ) : Boolean; 1068 { return TRUE if successful (BCD valid) } 1069 1070 var 1071 pre : {$ifopt r+} 0..__hi_bh - __lo_bh + 1 {$else} Integer {$endif}; 1072 fra : {$ifopt r+} -1 * ( __hi_bh - __lo_bh + 1 )..__hi_bh - __lo_bh + 1 {$else} Integer {$endif}; 1073 tm : {$ifopt r+} 0..__hi_bh - __lo_bh + 1 - Pred ( MaxFmtBCDFractionSize ) {$else} Integer {$endif}; 1074 i : {$ifopt r+} low ( bh.FDig ) - 1..high ( bh.LDig ) {$else} Integer {$endif}; 1075 rp : {$ifopt r+} low ( BCD.Fraction )..high ( BCD.Fraction ) + 1 {$else} Integer {$endif}; 1076 ue : {$ifopt r+} 0..1 {$else} Integer {$endif}; 1077 v : {$ifopt r+} 0..10 {$else} Integer {$endif}; 1078 lnz : {$ifopt r+} low ( bh.FDig )..high ( bh.LDig ) {$else} Integer {$endif}; 1079 doround, 1080 lnzf : Boolean; 1081 1082 begin 1083 pack_BCD := False; 1084 BCD := NullBCD; 1085 WITH BCD, 1086 bh do 1087 begin 1088 lnzf := FDig <= 0; 1089 while lnzf do // skip leading 0 1090 if Singles[FDig] = 0 1091 then begin 1092 Inc ( FDig ); 1093 if FDig > 0 1094 then lnzf := False; 1095 end 1096 else lnzf := False; 1097 if FDig > 1 then FDig := 1; 1098 pre := LDig - FDig + 1; 1099 fra := Plac; 1100 doround := False; 1101 if fra >= MaxFmtBCDFractionSize 1102 then begin 1103 doround := True; 1104 tm := fra - Pred ( MaxFmtBCDFractionSize ); 1105{ dec ( pre, tm ); Dec/Inc error? } 1106 pre := pre - tm; 1107{ Dec ( fra, tm ); Dec/Inc error? } 1108 fra := fra - tm; 1109{ Dec ( LDig, tm ); Dec/Inc error? } 1110 LDig := LDig - tm; 1111 end; 1112 if pre > MaxFmtBCDFractionSize 1113 then begin 1114 doround := True; 1115 tm := pre - MaxFmtBCDFractionSize; 1116{ Dec ( pre, tm ); Dec/Inc error? } 1117 pre := pre - tm; 1118{ Dec ( fra, tm ); Dec/Inc error? } 1119 fra := fra - tm; 1120{ Dec ( LDig, tm ); Dec/Inc error? } 1121 LDig := LDig - tm; 1122 end; 1123 if fra < 0 1124 then EXIT; 1125 1126 if doround 1127 then begin 1128 v := Singles[fra + 1]; 1129 if v > 4 1130 then begin 1131 ue := 1; 1132 i := LDig; 1133 while ( i >= FDig ) AND ( ue <> 0 ) do 1134 begin 1135 v := Singles[i] + ue; 1136 ue := v DIV 10; 1137 Singles[i] := v MOD 10; 1138 Dec ( i ); 1139 end; 1140 if ue <> 0 1141 then begin 1142 Dec ( FDig ); 1143 Singles[FDig] := ue; 1144 Dec ( LDig ); 1145 Dec ( fra ); 1146 if fra < 0 1147 then EXIT; 1148 end; 1149 end; 1150 end; 1151 1152 lnzf := False; 1153 i := LDig; 1154 while ( i >= FDig ) AND ( NOT lnzf ) do // skip trailing 0 1155 begin 1156 if Singles[i] <> 0 1157 then begin 1158 lnz := i; 1159 lnzf := True; 1160 end; 1161 Dec ( i ); 1162 end; 1163 if lnzf 1164 then begin 1165 tm := LDig - lnz; 1166 if tm <> 0 1167 then begin 1168{ Dec ( pre, tm ); Dec/Inc error? } 1169 pre := pre - tm; 1170{ Dec ( fra, tm ); Dec/Inc error? } 1171 fra := fra - tm; 1172{ Dec ( LDig, tm ); Dec/Inc error? } 1173 LDig := LDig - tm; 1174 if fra < 0 1175 then begin 1176{ Dec ( pre, fra ); Dec/Inc error? } 1177 pre := pre - fra; 1178{ Dec ( LDig, fra ); Dec/Inc error? } 1179 LDig := LDig - fra; 1180 fra := 0; 1181 end; 1182 end; 1183 end 1184 else begin 1185 LDig := FDig; 1186 fra := 0; 1187 pre := 0; 1188 Neg := False; 1189 end; 1190 if pre <> 0 1191 then begin 1192 Precision := pre; 1193 rp := 0; 1194 i := FDig; 1195 while i <= LDig do 1196 begin 1197 if i < LDig 1198 then Fraction[rp] := ( Singles[i] SHL 4 ) OR Singles[i + 1] 1199 else Fraction[rp] := Singles[i] SHL 4; 1200 Inc ( rp ); 1201 Inc ( i, 2 ); 1202 end; 1203{$ifndef bigger_BCD} 1204 if Neg 1205 then SignSpecialPlaces := NegBit; 1206 SignSpecialPlaces := SignSpecialPlaces OR fra; 1207{$else} 1208 Negativ := Neg; 1209 Places := fra; 1210{$endif} 1211 end; 1212 end; 1213 pack_BCD := True; 1214 end; 1215 1216 function BCDPrecision ( const BCD : tBCD ) : Word; Inline; 1217 1218 begin 1219 BCDPrecision := BCD.Precision; 1220 end; 1221 1222 function BCDScale ( const BCD : tBCD ) : Word; Inline; 1223 1224 begin 1225{$ifndef bigger_BCD} 1226 BCDScale := BCD.SignSpecialPlaces AND PlacesMask; 1227{$else} 1228 BCDScale := BCD.Places; 1229{$endif} 1230 end; 1231 1232 function IsBCDNegative ( const BCD : tBCD ) : Boolean; Inline; 1233 1234 begin 1235{$ifndef bigger_BCD} 1236 IsBCDNegative := ( BCD.SignSpecialPlaces AND NegBit ) <> 0; 1237{$else} 1238 IsBCDNegative := BCD.Negativ; 1239{$endif} 1240 end; 1241 1242{ BCD Arithmetic} 1243 1244 procedure BCDNegate ( var BCD : tBCD ); Inline; 1245 1246 begin 1247{ with-statement geht nicht !! 1248 with bcd do 1249 if precision <> 0 1250 then signspecialplaces := signspecialplaces xor negbit; 1251} 1252 if BCD.Precision <> 0 1253 then 1254{$ifndef bigger_BCD} 1255 BCD.SignSpecialPlaces := BCD.SignSpecialPlaces XOR NegBit; 1256{$else} 1257 BCD.Negativ := NOT BCD.Negativ; 1258{$endif} 1259 end; 1260 1261{ returns -1 if BCD1 < BCD2, 0 if BCD1 = BCD2, 1 if BCD1 > BCD2 } 1262 function BCDCompare ( const BCD1, 1263 BCD2 : tBCD ) : Integer; 1264 1265 var 1266 pl1 : {$ifopt r+} 0..maxfmtbcdfractionsize - 1 {$else} Integer {$endif}; 1267 pl2 : {$ifopt r+} 0..maxfmtbcdfractionsize - 1 {$else} Integer {$endif}; 1268 pr1 : {$ifopt r+} 0..maxfmtbcdfractionsize {$else} Integer {$endif}; 1269 pr2 : {$ifopt r+} 0..maxfmtbcdfractionsize {$else} Integer {$endif}; 1270 pr : {$ifopt r+} 0..maxfmtbcdfractionsize {$else} Integer {$endif}; 1271 idig1 : {$ifopt r+} 0..maxfmtbcdfractionsize {$else} Integer {$endif}; 1272 idig2 : {$ifopt r+} 0..maxfmtbcdfractionsize {$else} Integer {$endif}; 1273 i : {$ifopt r+} __low_Fraction..__high_Fraction + 1 {$else} Integer {$endif}; 1274 f1 : {$ifopt r+} $00..$99 {$else} Integer {$endif}; 1275 f2 : {$ifopt r+} $00..$99 {$else} Integer {$endif}; 1276 res : {$ifopt r+} -1..1 {$else} Integer {$endif}; 1277 neg1, 1278 neg2 : Boolean; 1279 1280 begin 1281{$ifndef bigger_BCD} 1282 neg1 := ( BCD1.SignSpecialPlaces AND NegBit ) <> 0; 1283 neg2 := ( BCD2.SignSpecialPlaces AND NegBit ) <> 0; 1284{$else} 1285 neg1 := BCD1.Negativ; 1286 neg2 := BCD2.Negativ; 1287{$endif} 1288 _SELECT 1289 _WHEN neg1 AND ( NOT neg2 ) 1290 _THEN result := -1; 1291 _WHEN ( NOT neg1 ) AND neg2 1292 _THEN result := +1; 1293 _WHENOTHER 1294 pr1 := BCD1.Precision; 1295 pr2 := BCD2.Precision; 1296{$ifndef bigger_BCD} 1297 pl1 := BCD1.SignSpecialPlaces AND PlacesMask; 1298 pl2 := BCD2.SignSpecialPlaces AND PlacesMask; 1299{$else} 1300 pl1 := BCD1.Places; 1301 pl2 := BCD2.Places; 1302{$endif} 1303 idig1 := pr1 - pl1; 1304 idig2 := pr2 - pl2; 1305 if idig1 <> idig2 1306 then begin 1307 if ( idig1 > idig2 ) = neg1 1308 then result := -1 1309 else result := +1; 1310 end 1311 else begin 1312 if pr1 < pr2 1313 then pr := pr1 1314 else pr := pr2; 1315 1316 res := 0; 1317 i := __low_Fraction; 1318 while ( res = 0 ) AND ( i < ( __low_Fraction + ( pr DIV 2 ) ) ) do 1319 begin 1320 _SELECT 1321 _WHEN BCD1.Fraction[i] < BCD2.Fraction[i] 1322 _THEN res := -1 1323 _WHEN BCD1.Fraction[i] > BCD2.Fraction[i] 1324 _THEN res := +1; 1325 _WHENOTHER 1326 _endSELECT; 1327 Inc ( i ); 1328 end; 1329 1330 if res = 0 1331 then begin 1332 if Odd ( pr ) 1333 then begin 1334 f1 := BCD1.Fraction[i] AND $f0; 1335 f2 := BCD2.Fraction[i] AND $f0; 1336 _SELECT 1337 _WHEN f1 < f2 1338 _THEN res := -1 1339 _WHEN f1 > f2 1340 _THEN res := +1; 1341 _endSELECT; 1342 end; 1343 1344 if res = 0 then 1345 if pr1 > pr2 then 1346 res := +1 1347 else if pr1 < pr2 then 1348 res := -1; 1349 end; 1350 1351 if neg1 1352 then result := 0 - res 1353 else result := res; 1354 end; 1355 _endSELECT 1356 end; 1357 1358{ Convert string/Double/Integer to BCD struct } 1359 1360 function TryStrToBCD ( const aValue : FmtBCDStringtype; 1361 var BCD : tBCD ) : Boolean; 1362 begin 1363 Result := TryStrToBCD(aValue, BCD, DefaultFormatSettings); 1364 end; 1365 1366 function TryStrToBCD ( const aValue : FmtBCDStringtype; 1367 var BCD : tBCD; 1368 Const Format : TFormatSettings) : Boolean; 1369 var 1370{$ifndef use_ansistring} 1371 lav : {$ifopt r+} 0..high ( aValue ) {$else} Integer {$endif}; 1372 i : {$ifopt r+} 0..high ( aValue ) {$else} Integer {$endif}; 1373{$else} 1374 lav : {$ifopt r+} longword {$else} longword {$endif}; 1375 i : {$ifopt r+} longword {$else} longword {$endif}; 1376{$endif} 1377 ch : Char; 1378 1379 type 1380 ife = ( inint, infrac, inexp ); 1381 1382{$define max_exp_scanned := 9999 } 1383 var 1384 inife : ife; 1385 lvars : record 1386 fp, 1387 lp : ARRAY [ ife ] 1388{$ifndef use_ansistring} 1389 of {$ifopt r+} 0..high ( aValue ) {$else} Integer {$endif}; 1390 pfnb : {$ifopt r+} 0..high ( aValue ) {$else} Integer {$endif}; 1391 ps : {$ifopt r+} 0..high ( aValue ) {$else} Integer {$endif}; 1392 pse : {$ifopt r+} 0..high ( aValue ) {$else} Integer {$endif}; 1393 errp : {$ifopt r+} 0..high ( aValue ) {$else} Integer {$endif}; 1394{$else} 1395 of {$ifopt r+} longword {$else} longword {$endif}; 1396 pfnb : {$ifopt r+} longword {$else} longword {$endif}; 1397 ps : {$ifopt r+} longword {$else} longword {$endif}; 1398 pse : {$ifopt r+} longword {$else} longword {$endif}; 1399 errp : {$ifopt r+} longword {$else} longword {$endif}; 1400{$endif} 1401 exp : {$ifopt r+} -max_exp_scanned..max_exp_scanned {$else} Integer {$endif}; 1402 p : {$ifopt r+} -max_exp_scanned..max_exp_scanned {$else} Integer {$endif}; 1403 bh : tBCD_helper; 1404 nbf : Boolean; 1405 end; 1406 1407 begin 1408 result := True; 1409 FillChar ( lvars, SizeOf ( lvars ), #0 ); 1410 BCD := NullBCD; 1411 lav := Length ( aValue ); 1412 if lav <> 0 1413 then 1414 WITH lvars, 1415 bh do 1416 begin 1417 while ( pfnb < lav ) AND ( NOT nbf ) do // skip leading spaces 1418 begin 1419 Inc ( pfnb ); 1420 nbf := aValue[pfnb] <> ' '; 1421 end; 1422 if nbf 1423 then begin 1424 if aValue[pfnb] IN [ '+', '-' ] 1425 then begin 1426 ps := pfnb; // position of sign 1427 Inc ( pfnb ); 1428 end; 1429 inife := low ( inife ); 1430 for i := pfnb TO lav do 1431 begin 1432 ch := aValue[i]; 1433 case ch of 1434 '0'..'9': begin 1435 case inife of 1436 inint, 1437 inexp: if fp[inife] = 0 1438 then begin 1439 if ch <> '0' 1440 then begin 1441 fp[inife] := i; 1442 lp[inife] := i; 1443 end; 1444 end 1445 else lp[inife] := i; 1446 infrac: begin 1447 if fp[infrac] = 0 1448 then fp[infrac] := i; 1449 if ch <> '0' 1450 then lp[infrac] := i; 1451 end; 1452 end; 1453 end; 1454 ',', 1455 '.': if ch = Format.DecimalSeparator then 1456 begin 1457 if inife <> inint then result := False 1458 else inife := infrac; 1459 end; 1460 'e', 1461 'E': if inife = inexp 1462 then result := False 1463 else inife := inexp; 1464 '+', 1465 '-': if ( inife = inexp ) AND ( fp[inexp] = 0 ) 1466 then pse := i // position of exponent sign 1467 else result := False; 1468 else begin 1469 result := False; 1470 errp := i; 1471 end; 1472 end; 1473 end; 1474 if not result 1475 then begin 1476 result := True; 1477 for i := errp TO lav do // skip trailing spaces 1478 if aValue[i] <> ' ' 1479 then result := False; 1480 end; 1481 if not result 1482 then EXIT; 1483 1484 if ps <> 0 1485 then Neg := aValue[ps] = '-'; 1486 if lp[infrac] = 0 1487 then fp[infrac] := 0; 1488 if fp[inexp] <> 0 1489 then begin 1490 exp := 0; 1491 for i := fp[inexp] TO lp[inexp] do 1492 if result 1493 then 1494 if aValue[i] <> Format.ThousandSeparator 1495 then begin 1496 exp := exp * 10 + ( Ord ( aValue[i] ) - Ord ( '0' ) ); 1497 if exp > 999 1498 then result := False; 1499 end; 1500 if not result 1501 then EXIT; 1502 1503 if pse <> 0 1504 then 1505 if aValue[pse] = '-' 1506 then exp := -exp; 1507 end; 1508 1509 p := -exp; 1510 if fp[infrac] <> 0 1511 then begin 1512 for i := fp[infrac] TO lp[infrac] do 1513 if aValue[i] <> Format.ThousandSeparator 1514 then begin 1515 if p < ( MaxFmtBCDFractionSize + 2 ) 1516 then begin 1517 Inc ( p ); 1518 Singles[p] := Ord ( aValue[i] ) - Ord ( '0' ); 1519 end; 1520 end; 1521 end; 1522 LDig := p; 1523 p := 1 - exp; 1524 if fp[inint] <> 0 1525 then 1526 for i := lp[inint] DOWNTO fp[inint] do 1527 if aValue[i] <> Format.ThousandSeparator 1528 then begin 1529 if p > - ( MaxFmtBCDFractionSize + 2 ) 1530 then begin 1531 Dec ( p ); 1532 Singles[p] := Ord ( aValue[i] ) - Ord ( '0' ); 1533 end 1534 else result := False; 1535 end; 1536 if not result 1537 then EXIT; 1538 1539 FDig := p; 1540 if LDig < 0 1541 then LDig := 0; 1542 Plac := LDig; 1543 result := pack_BCD ( bh, BCD ); 1544 end; 1545 end; 1546 end; 1547 1548 function StrToBCD ( const aValue : FmtBCDStringtype ) : tBCD; 1549 begin 1550 Result := StrToBCD(aValue, DefaultFormatSettings); 1551 end; 1552 1553 function StrToBCD ( const aValue : FmtBCDStringtype; 1554 Const Format : TFormatSettings ) : tBCD; 1555 begin 1556 if not TryStrToBCD ( aValue, Result, Format ) then 1557 raise eBCDOverflowException.create ( 'in StrToBCD' ); 1558 end; 1559 1560{$ifndef FPUNONE} 1561 procedure DoubleToBCD ( const aValue : myRealtype; 1562 var BCD : tBCD ); 1563 1564 var 1565 s : string [ 30 ]; 1566 f : TFormatSettings; 1567 1568 begin 1569 Str ( aValue : 25, s ); 1570 f.DecimalSeparator := '.'; 1571 f.ThousandSeparator := #0; 1572 BCD := StrToBCD ( s, f ); 1573 end; 1574 1575 function DoubleToBCD ( const aValue : myRealtype ) : tBCD; Inline; 1576 1577 begin 1578 DoubleToBCD ( aValue, result ); 1579 end; 1580{$endif} 1581 1582 function IntegerToBCD ( const aValue : myInttype ) : tBCD; 1583 1584 var 1585 bh : tBCD_helper; 1586 v : {$ifopt r+} 0..high ( myInttype ) {$else} Integer {$endif}; 1587 p : {$ifopt r+} low ( bh.Singles ) - 1..0 {$else} Integer {$endif}; 1588 exitloop : Boolean; 1589 1590 begin 1591 _SELECT 1592 _WHEN aValue = 0 1593 _THEN result := ZeroBCD; 1594 _WHEN aValue = 1 1595 _THEN result := OneBCD; 1596 _WHEN aValue = low ( myInttype ) 1597 _THEN 1598{$if declared ( myMinIntBCD ) } 1599 result := myMinIntBCD; 1600{$else} 1601 RAISE eBCDOverflowException.create ( 'in IntegerToBCD' ); 1602{$endif} 1603 _WHENOTHER 1604 bh := null_.bh; 1605 WITH bh do 1606 begin 1607 Neg := aValue < 0; 1608 if Neg 1609 then v := -aValue 1610 else v := +aValue; 1611 LDig := 0; 1612 p := 0; 1613 REPEAT 1614 Singles[p] := v MOD 10; 1615 v := v DIV 10; 1616 exitloop := v = 0; 1617 Dec ( p ); 1618 if p < low ( Singles ) 1619 then begin 1620 exitloop := True; 1621(* what to do if error occurred? *) 1622 RAISE eBCDOverflowException.create ( 'in IntegerToBCD' ); 1623 end; 1624 UNTIL exitloop; 1625 FDig := p + 1; 1626 end; 1627 pack_BCD ( bh, result ); 1628 _endSELECT; 1629 end; 1630 1631 function CurrToBCD ( const Curr : currency; 1632 var BCD : tBCD; 1633 Precision : Integer = 32; 1634 Decimals : Integer = 4 ) : Boolean; 1635 1636{ 1637 this works under the assumption that a currency is an int64, 1638 except for scale of 10000 1639} 1640 1641 var 1642 i : int64 absolute Curr; 1643 1644 begin 1645 BCD := IntegerToBCD ( i ); 1646{$ifndef bigger_BCD} 1647 BCD.SignSpecialPlaces := 4 OR ( BCD.SignSpecialPlaces AND NegBit ); 1648{$else} 1649 BCD.Places := 4; 1650{$endif} 1651 if (Decimals <> 4) or (Decimals > BCD.Precision) then 1652 Result := NormalizeBCD ( BCD, BCD, Precision, Decimals ) 1653 else 1654 Result := True; 1655 end; 1656 1657{$ifdef comproutines} 1658 function CompToBCD ( const Curr : Comp ) : tBCD; Inline; 1659 1660 var 1661 cc : int64 absolute Curr; 1662 1663 begin 1664 result := IntegerToBCD ( cc ); 1665 end; 1666 1667 function BCDToComp ( const BCD : tBCD ) : Comp; Inline; 1668 1669 var 1670 zz : record 1671 case Boolean of 1672 False: ( i : int64 ); 1673 True: ( c : Comp ); 1674 end; 1675 1676 begin 1677 zz.i := BCDToInteger ( BCD ); 1678 BCDToComp := zz.c; 1679 end; 1680{$endif} 1681 1682{ Convert BCD struct to string/Double/Integer } 1683 function BCDToStr ( const BCD : tBCD ) : FmtBCDStringtype; 1684 begin 1685 Result := BCDToStr(BCD, DefaultFormatSettings); 1686 end; 1687 1688 function BCDToStr ( const BCD : tBCD; 1689 Const Format : TFormatSettings ) : FmtBCDStringtype; 1690 var 1691 bh : tBCD_helper; 1692 l : {$ifopt r+} 0..maxfmtbcdfractionsize + 1 + 1 {$else} Integer {$endif}; 1693 i : {$ifopt r+} low ( bh.FDig )..high ( bh.LDig ) {$else} Integer {$endif}; 1694 pp : {$ifopt r+} low ( bh.FDig ) - 1..1 {$else} Integer {$endif}; 1695 1696 begin 1697{$ifdef use_ansistring} 1698 result := ''; 1699{$endif} 1700 unpack_BCD ( BCD, bh ); 1701 WITH bh do 1702 begin 1703 l := 0; 1704 if Neg then 1705 begin 1706{$ifndef use_ansistring} 1707 Inc ( l ); 1708 result[l] := '-'; 1709{$else} 1710 result := result + '-'; 1711{$endif} 1712 end; 1713 if Plac >= Prec then 1714 begin 1715 // insert leading 0 before decimal point 1716{$ifndef use_ansistring} 1717 Inc ( l ); 1718 result[l] := '0'; 1719{$else} 1720 result := result + '0'; 1721{$endif} 1722 end; 1723 if Prec > 0 then 1724 begin 1725 if Plac > 0 then 1726 begin 1727 if Plac > Prec then FDig := 1; 1728 pp := 1; 1729 end 1730 else 1731 pp := low ( bh.FDig ) - 1; // there is no decimal point 1732 for i := FDig TO LDig do 1733 begin 1734 if i = pp then 1735 begin 1736{$ifndef use_ansistring} 1737 Inc ( l ); 1738 result[l] := Format.DecimalSeparator; 1739{$else} 1740 result := result + Format.DecimalSeparator; 1741{$endif} 1742 end; 1743{$ifndef use_ansistring} 1744 Inc ( l ); 1745 result[l] := Chr ( Singles[i] + Ord ( '0' ) ); 1746{$else} 1747 result := result + Chr ( Singles[i] + Ord ( '0' ) ); 1748{$endif} 1749 end; 1750 end; 1751 end; 1752{$ifndef use_ansistring} 1753 result[0] := Chr ( l ); 1754{$endif} 1755 end; 1756 1757{$ifndef FPUNONE} 1758 function BCDToDouble ( const BCD : tBCD ) : myRealtype; 1759 1760 var 1761 bh : tBCD_helper; 1762 i : {$ifopt r+} low ( bh.FDig )..high ( bh.LDig ) {$else} Integer {$endif}; 1763 r, 1764 e : myRealtype; 1765 1766 begin 1767 unpack_BCD ( BCD, bh ); 1768 WITH bh do 1769 begin 1770 r := 0; 1771 e := 1; 1772 for i := 0 DOWNTO FDig do 1773 begin 1774 r := r + Singles[i] * e; 1775 e := e * 10; 1776 end; 1777 e := 1; 1778 for i := 1 TO LDig do 1779 begin 1780 e := e / 10; 1781 r := r + Singles[i] * e; 1782 end; 1783 if Neg 1784 then BCDToDouble := -r 1785 else BCDToDouble := +r; 1786 end; 1787 end; 1788{$endif} 1789 1790 function BCDToInteger ( const BCD : tBCD; 1791 Truncate : Boolean = False ) : myInttype; 1792 1793 var 1794 bh : tBCD_helper; 1795 res : myInttype; 1796 i : {$ifopt r+} low ( bh.FDig )..0 {$else} Integer {$endif}; 1797 1798{ 1799 unclear: behaviour if overflow: abort? return 0? return something? 1800 1801 so: checks are missing yet 1802} 1803 1804 begin 1805 unpack_BCD ( BCD, bh ); 1806 res := 0; 1807 WITH bh do 1808 begin 1809 for i := FDig TO 0 do 1810 res := res * 10 - Singles[i]; 1811 if NOT Truncate 1812 then 1813 if Plac > 0 1814 then 1815 if Singles[1] > 4 1816 then Dec ( res ); 1817 if Neg 1818 then BCDToInteger := +res 1819 else BCDToInteger := -res; 1820 end; 1821 end; 1822 1823{ From DB.pas } 1824 function BCDToCurr ( const BCD : tBCD; 1825 var Curr : currency ) : Boolean; 1826 1827 const 1828 MaxCurr: array[boolean] of QWord = (QWord($7FFFFFFFFFFFFFFF), QWord($8000000000000000)); 1829 var 1830 bh : tBCD_helper; 1831 res : QWord; 1832 c : currency absolute res; 1833 i : {$ifopt r+} low ( bh.FDig )..4 {$else} Integer {$endif}; 1834 1835{ 1836 unclear: behaviour if overflow: abort? return 0? return something? 1837} 1838 1839 begin 1840 BCDToCurr := False; 1841 if BCDPrecision(BCD) - BCDScale(BCD) > 15 then 1842 Exit; 1843 unpack_BCD ( BCD, bh ); 1844 res := 0; 1845 WITH bh do 1846 begin 1847 for i := FDig TO 4 do 1848 res := res * 10 + Singles[i]; 1849 if Plac > 4 1850 then 1851 if Singles[5] > 4 1852 then Inc ( res ); 1853 if res > MaxCurr[Neg] then 1854 Exit; 1855 if Neg then 1856 begin 1857 res := not res; 1858 inc(res); 1859 end; 1860 Curr := c; 1861 BCDToCurr := True; 1862 end; 1863 end; 1864 1865 procedure BCDAdd ( const BCDin1, 1866 BCDin2 : tBCD; 1867 var BCDout : tBCD ); 1868 1869 var 1870 bhr, 1871 bh1, 1872 bh2 : tBCD_helper; 1873 ue : {$ifopt r+} 0..1 {$else} Integer {$endif}; 1874 i : {$ifopt r+} low ( bh1.FDig )..high ( bh1.LDig ) {$else} Integer {$endif}; 1875 v : {$ifopt r+} 0..9 + 9 + 1 {$else} Integer {$endif}; 1876 BCD : tBCD; 1877 negate : Boolean; 1878 1879 begin 1880 negate := IsBCDNegative ( BCDin1 ); 1881 if negate <> IsBCDNegative ( BCDin2 ) 1882 then begin 1883 if negate 1884 then begin 1885 BCD := BCDin1; 1886 BCDNegate ( BCD ); 1887 BCDSubtract ( BCDin2, BCD, BCDout ); 1888 EXIT; 1889 end; 1890 1891 BCD := BCDin2; 1892 BCDNegate ( BCD ); 1893 BCDSubtract ( BCDin1, BCD, BCDout ); 1894 EXIT; 1895 end; 1896 1897 bhr := null_.bh; 1898 WITH bhr do 1899 begin 1900 unpack_BCD ( BCDin1, bh1 ); 1901 unpack_BCD ( BCDin2, bh2 ); 1902 if bh1.FDig < bh2.FDig 1903 then FDig := bh1.FDig 1904 else FDig := bh2.FDig; 1905 if bh1.LDig > bh2.LDig 1906 then LDig := bh1.LDig 1907 else LDig := bh2.LDig; 1908 Plac := LDig; 1909 ue := 0; 1910 for i := LDig DOWNTO FDig do 1911 begin 1912 v := bh1.Singles[i] + bh2.Singles[i] + ue; 1913 ue := v DIV 10; 1914 Singles[i] := v MOD 10; 1915 end; 1916 if ue <> 0 1917 then begin 1918 Dec ( FDig ); 1919 Singles[FDig] := ue; 1920 end; 1921 Neg := negate; 1922 end; 1923 if NOT pack_BCD ( bhr, BCDout ) 1924 then begin 1925 RAISE eBCDOverflowException.create ( 'in BCDAdd' ); 1926 end; 1927 end; 1928 1929 procedure BCDSubtract ( const BCDin1, 1930 BCDin2 : tBCD; 1931 var BCDout : tBCD ); 1932 1933 var 1934 bhr, 1935 bh1, 1936 bh2 : tBCD_helper; 1937 cmp : {$ifopt r+} -1..1 {$else} Integer {$endif}; 1938 ue : {$ifopt r+} 0..1 {$else} Integer {$endif}; 1939 i : {$ifopt r+} low ( bh1.FDig )..high ( bh1.LDig ) {$else} Integer {$endif}; 1940 v : {$ifopt r+} 0 - 9 - 1..9 - 0 - 0 {$else} Integer {$endif}; 1941 negate : Boolean; 1942 BCD : tBCD; 1943 1944 begin 1945 negate := IsBCDNegative ( BCDin1 ); 1946 if negate <> IsBCDNegative ( BCDin2 ) 1947 then begin 1948 if negate 1949 then begin 1950 BCD := BCDin1; 1951 BCDNegate ( BCD ); 1952 BCDAdd ( BCDin2, BCD, BCDout ); 1953 BCDNegate ( BCDout ); 1954 EXIT; 1955 end; 1956 1957 BCD := BCDin2; 1958 BCDNegate ( BCD ); 1959 BCDAdd ( BCDin1, BCD, BCDout ); 1960 EXIT; 1961 end; 1962 1963 cmp := BCDCompare ( BCDin1, BCDin2 ); 1964 if cmp = 0 1965 then begin 1966 BCDout := NullBCD; 1967 EXIT; 1968 end; 1969 1970 bhr := null_.bh; { n n } 1971 WITH bhr do { > < > < } 1972 begin { } 1973 if ( cmp > 0 ) = negate { +123 +12 -12 -123 } 1974 then begin { - +12 - +123 - -123 - -12 } 1975 unpack_BCD ( BCDin1, bh2 ); { x x } 1976 unpack_BCD ( BCDin2, bh1 ); { s s s s } 1977 negate := NOT negate; { nn n nn n } 1978 end 1979 else begin 1980 unpack_BCD ( BCDin1, bh1 ); 1981 unpack_BCD ( BCDin2, bh2 ); 1982 end; 1983 if bh1.FDig < bh2.FDig 1984 then FDig := bh1.FDig 1985 else FDig := bh2.FDig; 1986 if bh1.LDig > bh2.LDig 1987 then LDig := bh1.LDig 1988 else LDig := bh2.LDig; 1989 Plac := LDig; 1990 ue := 0; 1991 for i := LDig DOWNTO FDig do 1992 begin 1993 v := Integer ( bh1.Singles[i] ) - bh2.Singles[i] - ue; 1994 ue := 0; 1995 if v < 0 1996 then begin 1997 ue := 1; 1998 Inc ( v, 10 ); 1999 end; 2000 Singles[i] := v; 2001 end; 2002 Neg := negate; 2003 if NOT pack_BCD ( bhr, BCDout ) 2004 then begin 2005{should never occur!} 2006 RAISE eBCDOverflowException.create ( 'in BCDSubtract' ); 2007 end; 2008 end; 2009 end; 2010 2011{ Returns True if successful, False if Int Digits needed to be truncated } 2012 function NormalizeBCD ( const InBCD : tBCD; 2013 var OutBCD : tBCD; 2014 const Precision, 2015 Places : Integer ) : Boolean; 2016 2017 var 2018 bh : tBCD_helper; 2019 tm : {$ifopt r+} __lo_bh..__hi_bh {$else} Integer {$endif}; 2020 2021 begin 2022{$ifopt r+} 2023 if ( Precision < 0 ) OR ( Precision > MaxFmtBCDFractionSize ) then RangeError; 2024 if ( Places < 0 ) OR ( Precision >= MaxFmtBCDFractionSize ) then RangeError; 2025{$endif} 2026 if (BCDScale(InBCD) > Places) or (BCDPrecision(InBCD) < Places) then 2027 begin 2028 unpack_BCD ( InBCD, bh ); 2029 tm := bh.Plac - Places; 2030 bh.Plac := Places; 2031{ dec ( prec, tm ); Dec/Inc error? } 2032 bh.Prec := bh.Prec - tm; 2033{ dec ( LDig, tm ); Dec/Inc error? } 2034 bh.LDig := bh.LDig - tm; 2035 NormalizeBCD := tm <= 0; 2036 if NOT pack_BCD ( bh, OutBCD ) then 2037 RAISE eBCDOverflowException.Create ( 'in NormalizeBCD' ); 2038 end 2039 else 2040 begin 2041 OutBCD := InBCD; 2042 NormalizeBCD := True; 2043 end 2044 end; 2045 2046 procedure BCDMultiply ( const BCDin1, 2047 BCDin2 : tBCD; 2048 var BCDout : tBCD ); 2049 2050 var 2051 bh1, 2052 bh2, 2053 bhr : tBCD_helper; 2054 bhrr : tBCD_helper_big; 2055 i1 : {$ifopt r+} low ( bh1.FDig )..high ( bh1.LDig ) {$else} Integer {$endif}; 2056 i2 : {$ifopt r+} low ( bh2.FDig )..high ( bh2.LDig ) {$else} Integer {$endif}; 2057 i3 : {$ifopt r+} low ( bhrr.FDig )..high ( bhrr.LDig ) {$else} Integer {$endif}; 2058 v : {$ifopt r+} low ( bhrr.Singles[0] )..high ( bhrr.Singles[0] ) {$else} Integer {$endif}; 2059 ue : {$ifopt r+} low ( bhrr.Singles[0] ) DIV 10..high ( bhrr.Singles[0] ) DIV 10 {$else} Integer {$endif}; 2060 2061 begin 2062 unpack_BCD ( BCDin1, bh1 ); 2063 unpack_BCD ( BCDin2, bh2 ); 2064 if ( bh1.Prec = 0 ) OR ( bh2.Prec = 0 ) 2065 then begin 2066 BCDout := NullBCD; 2067 EXIT; 2068 end; 2069 2070 bhr := null_.bh; 2071 bhrr := null_.bhb; 2072 WITH bhrr do 2073 begin 2074 Neg := bh1.Neg XOR bh2.Neg; 2075{ 2076writeln ( __lo_bhb, ' ', __hi_bhb, ' ', bh1.fdig, ' ', bh2.fdig, ' ', low ( fdig ), ' ', low ( ldig ) ); 2077} 2078 FDig := bh1.FDig + bh2.FDig; 2079 LDig := bh1.LDig + bh2.LDig; 2080 for i1 := bh1.FDig TO bh1.LDig do 2081 for i2 := bh2.FDig TO bh2.LDig do 2082begin 2083 Inc ( Singles[i1 + i2], 2084 bh1.Singles[i1] 2085 * bh2.Singles[i2] ); 2086{ 2087write ( Singles[i1 + i2], ' ', bh1.Singles[i1], ' ', bh2.Singles[i2], ' : ' ); 2088writeln ( Singles[i1 + i2] + bh1.Singles[i1] + bh2.Singles[i2] ); 2089} 2090{ 2091 Singles[i1 + i2] := Singles[i1 + i2] 2092 + bh1.Singles[i1] 2093 * bh2.Singles[i2]; 2094} 2095end; 2096{ 2097for i3 := fdig to ldig do 2098 write ( ' ', singles[i3] ); 2099writeln; 2100} 2101 if FDig < low ( bhr.Singles ) 2102 then RAISE eBCDOverflowException.create ( 'in BCDMultiply' ); 2103 ue := 0; 2104 for i3 := LDig DOWNTO FDig do 2105 begin 2106 v := Singles[i3] + ue; 2107 ue := v DIV 10; 2108 v := v MOD 10; 2109 bhr.Singles[i3] := v; 2110 end; 2111 while ue <> 0 do 2112 begin 2113 Dec ( FDig ); 2114 if FDig < low ( bhr.Singles ) 2115 then RAISE eBCDOverflowException.create ( 'in BCDMultiply' ); 2116 bhr.Singles[FDig] := ue MOD 10; 2117 ue := ue DIV 10; 2118 end; 2119 bhr.neg := bh1.Neg XOR bh2.Neg; 2120 bhr.Plac := LDig; 2121 bhr.FDig := FDig; 2122 if LDig > high ( bhr.Singles ) 2123 then bhr.LDig := high ( bhr.Singles ) 2124 else bhr.LDig := LDig; 2125 end; 2126 if NOT pack_BCD ( bhr, BCDout ) 2127 then begin 2128 RAISE eBCDOverflowException.create ( 'in BCDMultiply' ); 2129 end; 2130 end; 2131 2132{$ifndef FPUNONE} 2133 procedure BCDMultiply ( const BCDIn : tBCD; 2134 const DoubleIn : myRealtype; 2135 var BCDout : tBCD ); Inline; 2136 2137 begin 2138 BCDMultiply ( BCDIn, DoubleToBCD ( DoubleIn ), BCDout ); 2139 end; 2140{$endif} 2141 2142 procedure BCDMultiply ( const BCDIn : tBCD; 2143 const StringIn : FmtBCDStringtype; 2144 var BCDout : tBCD ); Inline; 2145 2146 begin 2147 BCDMultiply ( BCDIn, StrToBCD ( StringIn ), BCDout ); 2148 end; 2149 2150 procedure BCDMultiply ( const StringIn1, 2151 StringIn2 : FmtBCDStringtype; 2152 var BCDout : tBCD ); Inline; 2153 2154 begin 2155 BCDMultiply ( StrToBCD ( StringIn1 ), StrToBCD ( StringIn2 ), BCDout ); 2156 end; 2157 2158 procedure BCDDivide ( const Dividend, 2159 Divisor : tBCD; 2160 var BCDout : tBCD ); 2161 2162 var 2163 bh1 : ARRAY [ Boolean ] of tBCD_helper; 2164 bh2, 2165 bh : tBCD_helper; 2166 p : {$ifopt r+} low ( bh.FDig ) - high ( bh.FDig )..high ( bh.FDig ) - low ( bh.FDig ) {$else} Integer {$endif}; 2167 v1 : {$ifopt r+} low ( bh.Singles[0] )..high ( bh.Singles[0] ) {$else} Integer {$endif}; 2168 v2 : {$ifopt r+} low ( bh.Singles[0] )..high ( bh.Singles[0] ) {$else} Integer {$endif}; 2169 lFDig : {$ifopt r+} low ( bh.FDig )..high ( bh.FDig ) {$else} Integer {$endif}; 2170 d1 : {$ifopt r+} low ( bh.LDig ) - high ( bh.FDig )..high ( bh.LDig ) - low ( bh.FDig ) {$else} Integer {$endif}; 2171 d2 : {$ifopt r+} low ( bh.LDig ) - high ( bh.FDig )..high ( bh.LDig ) - low ( bh.FDig ) {$else} Integer {$endif}; 2172 d : {$ifopt r+} low ( bh.LDig ) - high ( bh.FDig )..high ( bh.LDig ) - low ( bh.FDig ) {$else} Integer {$endif}; 2173 lLdig : {$ifopt r+} low ( lFDig ) + low ( d )..high ( lFDig ) + high ( d ) {$else} Integer {$endif}; 2174 tm : {$ifopt r+} low ( lLdig ) - high ( bh2.Singles )..high ( lLdig ) - high ( bh2.Singles ) {$else} Integer {$endif}; 2175 i2 : {$ifopt r+} low ( lFDig )..high ( lLdig ) {$else} Integer {$endif}; 2176 i3 : {$ifopt r+} low ( lFDig )..high ( lLdig ) {$else} Integer {$endif}; 2177 ie : {$ifopt r+} low ( lFDig )..high ( lLdig ) {$else} Integer {$endif}; 2178 i4 : {$ifopt r+} low ( lFDig )..high ( lLdig ) {$else} Integer {$endif}; 2179 nFDig : {$ifopt r+} low ( i2 )..high ( i2 ) {$else} Integer {$endif}; 2180 nLDig : {$ifopt r+} low ( i2 )..high ( i2 ) {$else} Integer {$endif}; 2181 dd : {$ifopt r+} 0..9 {$else} Integer {$endif}; 2182 Add : {$ifopt r+} 0..99 {$else} Integer {$endif}; 2183 ue : {$ifopt r+} 0..99 {$else} Integer {$endif}; 2184 v3 : {$ifopt r+} low ( bh.Singles[0] ) - high ( bh2.singles[9] ) * high ( dd ) - high ( ue )..high ( bh.Singles[0] ) - low ( bh2.singles[9] ) * low ( dd ) - low ( ue ) {$else} Integer {$endif}; 2185 v4 : {$ifopt r+} low ( bh.Singles[0] ) + low ( add )..high ( bh.Singles[0] ) + high ( add ) {$else} Integer {$endif}; 2186 FlipFlop, 2187 nz, 2188 sf, 2189 sh, 2190 fdset : Boolean; 2191{ 2192 bh1p : ARRAY [ Boolean ] of ^ tBCD_helper; 2193} 2194 2195 begin 2196{ test: 2197 bh1p[false] := @ bh1[false]; 2198 bh1p[true] := @ bh1[true]; 2199 v := bh1[false].singles[0]; 2200 v := bh1[true].singles[0]; 2201 v := bh1p[false]^.singles[0]; 2202 v := bh1p[true]^.singles[0]; 2203 v := bh1[nz].singles[0]; 2204 v := bh1p[nz]^.singles[0]; 2205} 2206 unpack_BCD ( Divisor, bh2 ); 2207 unpack_BCD ( Dividend, bh1[False] ); 2208 p := bh1[False].FDig - bh2.FDig; 2209 _SELECT 2210 _WHEN bh2.Prec = 0 2211 _THEN RAISE eBCDException.create ( 'Division by zero' ); 2212 _WHEN bh1[False].Prec = 0 2213 _THEN BCDout := NullBCD; 2214 _WHEN p < low ( bh2.Singles ) 2215 _THEN RAISE eBCDOverflowException.create ( 'in BCDDivide' ); 2216 _WHENOTHER 2217 bh := null_.bh; 2218 bh.Neg := bh1[False].Neg XOR bh2.Neg; 2219 if p <= high ( bh.Singles ) 2220 then begin 2221 bh1[True] := null_.bh; 2222 FlipFlop := False; 2223 fdset := p > 0; 2224 Add := 0; 2225 nz := True; 2226 while nz do 2227 WITH bh1[FlipFlop] do 2228 begin 2229{ 2230WriteLn('#####'); 2231dumpbh ( bh1[flipflop] ); 2232dumpbh ( bh2 ); 2233dumpbh ( bh ); 2234} 2235 if ( Singles[FDig] + bh2.Singles[bh2.FDig] ) = 0 2236 then begin 2237 if ( FDig >= LDig ) 2238 OR ( bh2.FDig >= bh2.LDig ) 2239 then nz := False 2240 else begin 2241 Inc ( FDig ); 2242 Inc ( bh2.FDig ); 2243 end; 2244 end 2245 else begin 2246 v1 := Singles[FDig]; 2247 v2 := bh2.Singles[bh2.FDig]; 2248 sh := v1 < v2; 2249 if ( v1 = v2 ) 2250 then begin 2251 nz := False; 2252 i3 := Succ ( FDig ); 2253 ie := LDig; 2254 while ( i3 <= ie ) AND ( NOT nz ) AND ( NOT sh ) do 2255 begin 2256 v1 := Singles[i3]; 2257 v2 := bh2.Singles[i3 - p]; 2258 if v1 <> v2 2259 then begin 2260 nz := True; 2261 if v1 < v2 2262 then sh := True; 2263 end; 2264 Inc ( i3 ); 2265 end; 2266 end; 2267 if NOT nz 2268 then Add := 1 2269 else begin 2270 if sh 2271 then begin 2272 Inc ( p ); 2273{ 2274if p > 3 then halt; 2275} 2276 if p > high ( bh.Singles ) 2277 then nz := False 2278 else Dec ( bh2.FDig ); 2279 end 2280 else begin 2281 lFDig := FDig; 2282 d1 := LDig - FDig; 2283 d2 := bh2.LDig - bh2.FDig; 2284 if d1 > d2 2285 then d := d1 2286 else d := d2; 2287 lLdig := lFDig + d; 2288 if lLdig > high ( bh2.Singles ) 2289 then begin 2290 tm := ( lLdig ) - high ( bh2.Singles ); 2291 d := d - tm; 2292 lLdig := lLdig - tm; 2293 {runden?} 2294 end; 2295 sf := True; 2296 Add := 0; 2297 nFDig := 0; 2298 nLDig := 0; 2299 ue := 0; 2300 dd := Singles[lFDig] DIV ( bh2.Singles[lFDig - p] + 1 ); 2301 if dd < 1 2302 then dd := 1; 2303{ 2304writeln ( 'p=', p, ' dd=', dd, ' lFdig=', lfdig, ' lldig=', lldig ); 2305} 2306 2307 for i2 := lLdig DOWNTO lFDig do 2308 begin 2309 // Typecase needed on 64-bit because evaluation happens using qword... 2310 v3 := Longint(Singles[i2]) - Longint(bh2.Singles[i2 - p] * dd) - Longint(ue); 2311 ue := 0; 2312 while v3 < 0 do 2313 begin 2314 Inc ( ue );; 2315 v3 := v3 + 10; 2316 end; 2317{ 2318 if v3 <> 0 2319 then begin 2320} 2321 bh1[NOT FlipFlop].Singles[i2] := v3; 2322{ 2323 nFDig := i2; 2324 if sf 2325 then begin 2326 nLDig := i2; 2327 sf := False; 2328 end; 2329 end; 2330} 2331 end; 2332 sf := False; 2333 nFDig := lFDig; 2334 nLDig := lLDig; 2335 Inc ( Add, dd ); 2336 if sf 2337 then nz := False 2338 else begin 2339 FillChar ( bh1[FlipFlop], SizeOf ( bh1[FlipFlop] ), #0 ); 2340 FlipFlop := NOT FlipFlop; 2341 WITH bh1[FlipFlop] do 2342 begin 2343 FDig := nFDig; 2344 LDig := nLDig; 2345 end; 2346 end; 2347 end; 2348 end; 2349 2350 if Add <> 0 2351 then begin 2352 2353 if NOT fdset 2354 then begin 2355 bh.FDig := p; 2356 fdset := True; 2357 end; 2358 if bh.LDig < p 2359 then begin 2360 bh.LDig := p; 2361 if ( bh.LDig - bh.FDig ) > Succ ( MaxFmtBCDFractionSize ) 2362 then nz := False; 2363 end; 2364 2365 i4 := p; 2366 while ( Add <> 0 ) AND ( i4 >= bh.FDig ) do 2367 begin 2368{ 2369writeln ( '> ', i4, ' ', bh.Singles[i4], ' ', Add ); 2370} 2371 v4 := bh.Singles[i4] + Add; 2372 Add := v4 DIV 10; 2373 bh.Singles[i4] := v4 MOD 10; 2374 Dec ( i4 ); 2375 end; 2376 if Add <> 0 2377 then begin 2378 Dec ( bh.FDig ); 2379 bh.Singles[bh.FDig] := Add; 2380 Add := 0; 2381 end; 2382 end; 2383 end; 2384 end; 2385 end; 2386 WITH bh do 2387 begin 2388 if LDig < 0 2389 then LDig := 0; 2390 if LDig > 0 2391 then Plac := LDig 2392 else Plac := 0; 2393 end; 2394 if NOT pack_BCD ( bh, BCDout ) 2395 then begin 2396 RAISE eBCDOverflowException.create ( 'in BCDDivide' ); 2397 end; 2398 _endSELECT 2399 end; 2400 2401 procedure BCDDivide ( const Dividend, 2402 Divisor : FmtBCDStringtype; 2403 var BCDout : tBCD ); Inline; 2404 2405 begin 2406 BCDDivide ( StrToBCD ( Dividend ), StrToBCD ( Divisor ), BCDout ); 2407 end; 2408 2409{$ifndef FPUNONE} 2410 procedure BCDDivide ( const Dividend : tBCD; 2411 const Divisor : myRealtype; 2412 var BCDout : tBCD ); Inline; 2413 2414 begin 2415 BCDDivide ( Dividend, DoubleToBCD ( Divisor ), BCDout ); 2416 end; 2417{$endif} 2418 2419 procedure BCDDivide ( const Dividend : tBCD; 2420 const Divisor : FmtBCDStringtype; 2421 var BCDout : tBCD ); Inline; 2422 2423 begin 2424 BCDDivide ( Dividend, StrToBCD ( Divisor ), BCDout ); 2425 end; 2426 2427{ TBCD variant creation utils } 2428 procedure VarFmtBCDCreate ( var aDest : Variant; 2429 const aBCD : tBCD ); 2430 begin 2431 VarClear(aDest); 2432 TVarData(aDest).Vtype:=FMTBcdFactory.Vartype; 2433 TVarData(aDest).VPointer:=TFMTBcdVarData.create(aBCD); 2434 end; 2435 2436 function VarFmtBCDCreate : Variant; 2437 begin 2438 VarFmtBCDCreate ( result, NullBCD ); 2439 end; 2440 2441 function VarFmtBCDCreate ( const aValue : FmtBCDStringtype; 2442 Precision, 2443 Scale : Word ) : Variant; 2444 begin 2445 VarFmtBCDCreate ( result, StrToBCD ( aValue ) ); 2446 end; 2447 2448{$ifndef FPUNONE} 2449 function VarFmtBCDCreate ( const aValue : myRealtype; 2450 Precision : Word = 18; 2451 Scale : Word = 4 ) : Variant; 2452 2453 begin 2454 VarFmtBCDCreate ( result, DoubleToBCD ( aValue ) ); 2455 end; 2456{$endif} 2457 2458 function VarFmtBCDCreate ( const aBCD : tBCD ) : Variant; 2459 2460 begin 2461 VarFmtBCDCreate ( result, aBCD ); 2462 end; 2463 2464 2465 function VarIsFmtBCD ( const aValue : Variant ) : Boolean; 2466 begin 2467 Result:=TVarData(aValue).VType=FMTBcdFactory.VarType; 2468 end; 2469 2470 2471 function VarFmtBCD : TVartype; 2472 begin 2473 Result:=FMTBcdFactory.VarType; 2474 end; 2475 2476 2477 { Formatting BCD as string } 2478 function BCDToStrF ( const BCD : tBCD; 2479 Format : TFloatFormat; 2480 const Precision, 2481 Digits : Integer ) : FmtBCDStringtype; 2482 var P, E: integer; 2483 Negative: boolean; 2484 DS, TS: char; 2485 2486 procedure RoundDecimalDigits(const d: integer); 2487 var i,j: integer; 2488 begin 2489 j:=P+d; 2490 if (Length(Result) > j) and (Result[j+1] >= '5') then 2491 for i:=j downto 1+ord(Negative) do 2492 begin 2493 if Result[i] = '9' then 2494 begin 2495 Result[i] := '0'; 2496 if i = 1+ord(Negative) then 2497 begin 2498 Insert('1', Result, i); 2499 inc(P); 2500 inc(j); 2501 end; 2502 end 2503 else if Result[i] <> DS then 2504 begin 2505 inc(Result[i]); 2506 break; 2507 end; 2508 end; 2509 if d = 0 then dec(j); // if decimal separator is last char then do not copy them 2510 Result := copy(Result, 1, j); 2511 end; 2512 2513 procedure AddDecimalDigits(d: integer); 2514 var n: integer; 2515 begin 2516 if P > Length(Result) then // there isn't decimal separator 2517 if d = 0 then 2518 Exit 2519 else 2520 Result := Result + DS; 2521 2522 n := d + P - Length(Result); 2523 2524 if n > 0 then 2525 Result := Result + StringOfChar('0', n) 2526 else if n < 0 then 2527 RoundDecimalDigits(d); 2528 end; 2529 2530 procedure AddThousandSeparators; 2531 begin 2532 Dec(P, 3); 2533 While (P > 1) Do 2534 Begin 2535 If (Result[P - 1] <> '-') And (TS <> #0) Then 2536 Insert(TS, Result, P); 2537 Dec(P, 3); 2538 End; 2539 end; 2540 2541 begin 2542 Result := BCDToStr(BCD); 2543 if Format = ffGeneral then Exit; 2544 2545 DS:=DefaultFormatSettings.DecimalSeparator; 2546 TS:=DefaultFormatSettings.ThousandSeparator; 2547 2548 Negative := Result[1] = '-'; 2549 P := Pos(DS, Result); 2550 if P = 0 then 2551 P := Length(Result) + 1; 2552 2553 Case Format Of 2554 ffExponent: 2555 Begin 2556 E := P - 2 - ord(Negative); 2557 2558 if (E = 0) and (Result[P-1] = '0') then // 0.### 2559 repeat 2560 dec(E); 2561 until (Length(Result) <= P-E) or (Result[P-E] <> '0'); 2562 2563 if E <> 0 then 2564 begin 2565 System.Delete(Result, P, 1); 2566 dec(P, E); 2567 Insert(DS, Result, P); 2568 end; 2569 2570 AddDecimalDigits(Precision-1); 2571 2572 if E < 0 then 2573 begin 2574 System.Delete(Result, P+E-1, -E); 2575 Result := Result + SysUtils.Format('E%.*d' , [Digits,E]) 2576 end 2577 else 2578 Result := Result + SysUtils.Format('E+%.*d', [Digits,E]); 2579 End; 2580 2581 ffFixed: 2582 Begin 2583 AddDecimalDigits(Digits); 2584 End; 2585 2586 ffNumber: 2587 Begin 2588 AddDecimalDigits(Digits); 2589 AddThousandSeparators; 2590 End; 2591 2592 ffCurrency: 2593 Begin 2594 //implementation based on FloatToStrFIntl() 2595 if Negative then System.Delete(Result, 1, 1); 2596 2597 AddDecimalDigits(Digits); 2598 AddThousandSeparators; 2599 2600 If Not Negative Then 2601 Begin 2602 Case FormatSettings.CurrencyFormat Of 2603 0: Result := FormatSettings.CurrencyString + Result; 2604 1: Result := Result + FormatSettings.CurrencyString; 2605 2: Result := FormatSettings.CurrencyString + ' ' + Result; 2606 3: Result := Result + ' ' + FormatSettings.CurrencyString; 2607 End 2608 End 2609 Else 2610 Begin 2611 Case FormatSettings.NegCurrFormat Of 2612 0: Result := '(' + FormatSettings.CurrencyString + Result + ')'; 2613 1: Result := '-' + FormatSettings.CurrencyString + Result; 2614 2: Result := FormatSettings.CurrencyString + '-' + Result; 2615 3: Result := FormatSettings.CurrencyString + Result + '-'; 2616 4: Result := '(' + Result + FormatSettings.CurrencyString + ')'; 2617 5: Result := '-' + Result + FormatSettings.CurrencyString; 2618 6: Result := Result + '-' + FormatSettings.CurrencyString; 2619 7: Result := Result + FormatSettings.CurrencyString + '-'; 2620 8: Result := '-' + Result + ' ' + FormatSettings.CurrencyString; 2621 9: Result := '-' + FormatSettings.CurrencyString + ' ' + Result; 2622 10: Result := FormatSettings.CurrencyString + ' ' + Result + '-'; 2623 End; 2624 End; 2625 End; 2626 End; 2627 end; 2628 2629 2630 function FormatBCD ( const Format : string; 2631 BCD : tBCD ) : FmtBCDStringtype; 2632 // Tests: tests/test/units/fmtbcd/ 2633 type 2634 TSection=record 2635 FmtStart, FmtEnd, // positions in Format string, 2636 Fmt1Dig, // position of 1st digit placeholder, 2637 FmtDS: PChar; // position of decimal point 2638 Digits: integer; // number of all digit placeholders 2639 DigDS: integer; // number of digit placeholders after decimal separator 2640 HasTS, HasDS: boolean; // has thousand or decimal separator? 2641 end; 2642 2643 var 2644 PFmt: PChar; 2645 i, j, j1, je, ReqSec, Sec, Scale: integer; 2646 Section: TSection; 2647 FF: TFloatFormat; 2648 BCDStr: string; // BCDToStrF of given BCD parameter 2649 Buf: array [0..85] of char; // output buffer 2650 2651 // Parses Format parameter, their sections (positive;negative;zero) and 2652 // builds Section information for requested section 2653 procedure ParseFormat; 2654 var C,Q: Char; 2655 PFmtEnd: PChar; 2656 Section1: TSection; 2657 begin 2658 PFmt:=@Format[1]; 2659 PFmtEnd:=PFmt+length(Format); 2660 Section.FmtStart:=PFmt; 2661 Section.Fmt1Dig:=nil; 2662 Section.Digits:=0; 2663 Section.HasTS:=false; // has thousand separator? 2664 Section.HasDS:=false; // has decimal separator? 2665 Sec:=1; 2666 while true do begin 2667 if PFmt>=PFmtEnd then 2668 C:=#0 // hack if short strings used 2669 else 2670 C:=PFmt^; 2671 case C of 2672 '''', '"': 2673 begin 2674 Q:=PFmt^; 2675 inc(PFmt); 2676 while (PFmt<PFmtEnd-1) and (PFmt^<>Q) do 2677 inc(PFmt); 2678 end; 2679 #0, ';': // end of Format string or end of section 2680 begin 2681 if Sec > 1 then 2682 Section.FmtStart:=Section.FmtEnd+1; 2683 Section.FmtEnd:=PFmt; 2684 if not assigned(Section.Fmt1Dig) then 2685 Section.Fmt1Dig:=Section.FmtEnd; 2686 if not Section.HasDS then 2687 begin 2688 Section.FmtDS := Section.FmtEnd; 2689 Section.DigDS := 0; 2690 end; 2691 if Sec = 1 then 2692 Section1 := Section; 2693 if (C = #0) or (Sec=ReqSec) then 2694 break; 2695 Section.Fmt1Dig:=nil; 2696 Section.Digits:=0; 2697 Section.HasTS:=false; 2698 Section.HasDS:=false; 2699 inc(Sec); 2700 end; 2701 '.': // decimal point 2702 begin 2703 Section.HasDS:=true; 2704 Section.FmtDS:=PFmt; 2705 Section.DigDS:=0; 2706 end; 2707 ',': // thousand separator 2708 Section.HasTS:=true; 2709 '0','#': // digits placeholders 2710 begin 2711 if not assigned(Section.Fmt1Dig) then Section.Fmt1Dig:=PFmt; 2712 inc(Section.Digits); 2713 inc(Section.DigDS); 2714 end; 2715 end; 2716 inc(PFmt); 2717 end; 2718 2719 // if requested section does not exists or is empty use first section 2720 if (ReqSec > Sec) or (Section.FmtStart=Section.FmtEnd) then 2721 begin 2722 Section := Section1; 2723 Sec := 1; 2724 end; 2725 end; 2726 2727 procedure PutFmtDigit(var AFmt: PChar; var iBCDStr, iBuf: integer; MoveBy: integer); 2728 var ADig, Q: Char; 2729 begin 2730 if (iBuf < low(Buf)) or (iBuf > high(Buf)) then 2731 raise eBCDOverflowException.Create ( 'in FormatBCD' ); 2732 2733 if (iBCDStr < 1) or (iBCDStr > length(BCDStr)) then 2734 ADig:=#0 2735 else 2736 ADig:=BCDStr[iBCDStr]; 2737 2738 // write remaining leading part of BCDStr if there are no more digit placeholders in Format string 2739 if ((AFmt < Section.Fmt1Dig) and (AFmt < Section.FmtDS) and (ADig <> #0)) or 2740 (ADig = DefaultFormatSettings.ThousandSeparator) then 2741 begin 2742 Buf[iBuf] := BCDStr[iBCDStr]; 2743 inc(iBCDStr, MoveBy); 2744 inc(iBuf, MoveBy); 2745 Exit; 2746 end; 2747 2748 case AFmt^ of 2749 '''','"': 2750 begin 2751 Q:=AFmt^; 2752 inc(AFmt, MoveBy); 2753 // write all characters between quotes 2754 while (AFmt>Section.FmtStart) and (AFmt<Section.FmtEnd) and (AFmt^ <> Q) do 2755 begin 2756 Buf[iBuf] := AFmt^; 2757 inc(AFmt, MoveBy); 2758 inc(iBuf, MoveBy); 2759 end; 2760 end; 2761 '0','.': 2762 begin 2763 if AFmt^ = '.' then 2764 Buf[iBuf] := DefaultFormatSettings.DecimalSeparator 2765 else if ADig = #0 then 2766 Buf[iBuf] := '0' 2767 else 2768 Buf[iBuf] := ADig; 2769 inc(AFmt, MoveBy); 2770 inc(iBCDStr, MoveBy); 2771 inc(iBuf, MoveBy); 2772 end; 2773 '#': 2774 begin 2775 if ADig = #0 then 2776 inc(AFmt, MoveBy) 2777 else if (ADig = '0') and (iBCDStr = 1) then // skip leading zero 2778 begin 2779 inc(AFmt, MoveBy); 2780 inc(iBCDStr, MoveBy); 2781 end 2782 else 2783 begin 2784 Buf[iBuf] := ADig; 2785 inc(AFmt, MoveBy); 2786 inc(iBCDStr, MoveBy); 2787 inc(iBuf, MoveBy); 2788 end; 2789 end; 2790 ',': 2791 begin 2792 inc(AFmt, MoveBy); // thousand separators are already in BCDStr 2793 end; 2794 else // write character what is in Format as is 2795 begin 2796 Buf[iBuf] := AFmt^; 2797 inc(AFmt, MoveBy); 2798 inc(iBuf, MoveBy); 2799 end; 2800 end; 2801 end; 2802 2803 begin 2804 case BCDCompare(BCD, NullBCD) of 2805 1: ReqSec := 1; 2806 0: ReqSec := 3; 2807 -1: ReqSec := 2; 2808 end; 2809 2810 // remove sign for negative value 2811 if ReqSec = 2 then 2812 BCDNegate(BCD); 2813 2814 // parse Format into Section 2815 ParseFormat; 2816 2817 if Section.FmtStart=Section.FmtEnd then // empty section 2818 FF := ffGeneral 2819 else if Section.HasTS then 2820 FF := ffNumber 2821 else 2822 FF := ffFixed; 2823 2824 Scale := BCDScale(BCD); 2825 if (FF <> ffGeneral) and (Scale > Section.DigDS) then // we need rounding 2826 Scale := Section.DigDS; 2827 2828 BCDStr := BCDToStrF(BCD, FF, 64, Scale); 2829 if (FF = ffGeneral) then 2830 begin 2831 Result:=BCDStr; 2832 Exit; 2833 end; 2834 2835 // write to output buffer 2836 j1 := high(Buf); // position of 1st number before decimal point in output buffer 2837 je := length(Buf); // position after last digit in output buffer 2838 // output decimal part of BCDStr 2839 if Section.HasDS and (Section.FmtEnd-Section.FmtDS>1) then // is there something after decimal point? 2840 begin 2841 PFmt := Section.FmtDS; // start from decimal point until end 2842 i := length(BCDStr) - Scale + ord(Scale=0); 2843 dec(j1, Section.FmtEnd-Section.FmtDS); 2844 j := j1 + 1; 2845 while PFmt < Section.FmtEnd do 2846 PutFmtDigit(PFmt, i, j, 1); 2847 je := j; // store position after last decimal digit 2848 end; 2849 2850 // output whole number part of BCDStr 2851 PFmt := Section.FmtDS - 1; 2852 i := length(BCDStr) - Scale - ord(Scale<>0); 2853 j := j1; 2854 while (i>0) and (j>0) do 2855 PutFmtDigit(PFmt, i, j, -1); 2856 2857 // output leading '0' (f.e. '001.23') 2858 while (PFmt >= Section.FmtStart) and (PFmt^ = '0') do 2859 PutFmtDigit(PFmt, i, j, -1); 2860 2861 // output sign (-), if value is negative, and does not exists 2nd section 2862 if (ReqSec = 2) and (Sec = 1) then 2863 begin 2864 Buf[j]:='-'; 2865 dec(j); 2866 end; 2867 2868 // output remaining chars from begining of Format (f.e. 'abc' if given Format is 'abc0.00') 2869 while PFmt >= Section.FmtStart do 2870 PutFmtDigit(PFmt, i, j, -1); 2871 2872 inc(j); 2873 if j > high(Buf) then 2874 Result := '' 2875 else 2876 SetString(Result, @Buf[j], je-j); 2877 end; 2878 2879{$ifdef additional_routines} 2880 2881 function CurrToBCD ( const Curr : currency ) : tBCD; Inline; 2882 2883 begin 2884 CurrToBCD ( Curr, result ); 2885 end; 2886 2887 procedure BCDAdd ( const BCDIn : tBCD; 2888 const IntIn : myInttype; 2889 var BCDout : tBCD ); 2890 2891 var 2892 BCD : tBCD; 2893 bhr : tBCD_helper; 2894 p : {$ifopt r+} low ( bhr.FDig ) - 1..0 {$else} Integer {$endif}; 2895 ue : {$ifopt r+} 0..high ( IntIn ) - 9 {$else} Integer {$endif}; 2896 v : {$ifopt r+} 0..{high ( ue ) + 9} high ( IntIn ) {$else} Integer {$endif}; 2897 nz : Boolean; 2898 2899 begin 2900 if IntIn = 0 2901 then begin 2902 BCDout := BCDIn; 2903 EXIT; 2904 end; 2905 2906 if IntIn = low ( myInttype ) 2907 then begin 2908{$if declared ( myMinIntBCD ) } 2909 BCDAdd ( BCDIn, myMinIntBCD, BCDout ); 2910 EXIT; 2911{$else} 2912 RAISE eBCDOverflowException.create ( 'in BCDAdd' ); 2913{$endif} 2914 end; 2915 2916 if IsBCDNegative ( BCDIn ) 2917 then begin 2918 BCD := BCDIn; 2919 BCDNegate ( BCD ); 2920 if IntIn < 0 2921 then BCDAdd ( BCD, -IntIn, BCDout ) 2922 else BCDSubtract ( BCD, IntIn, BCDout ); 2923 BCDNegate ( BCDout ); 2924 EXIT; 2925 end; 2926 2927 if IntIn < 0 2928 then begin 2929 BCDSubtract ( BCDIn, -IntIn, BCDout ); 2930 EXIT; 2931 end; 2932 2933 if IntIn > ( high ( IntIn ) - 9 ) 2934 then begin 2935 BCDAdd ( BCDIn, IntegerToBCD ( IntIn ), BCDout ); 2936 EXIT; 2937 end; 2938 2939 unpack_BCD ( BCDIn, bhr ); 2940 p := 0; 2941 nz := True; 2942 ue := IntIn; 2943 while nz do 2944 begin 2945 v := bhr.Singles[p] + ue; 2946 bhr.Singles[p] := v MOD 10; 2947 ue := v DIV 10; 2948 if ue = 0 2949 then nz := False 2950 else Dec ( p ); 2951 end; 2952 if p < bhr.FDig 2953 then begin 2954 bhr.FDig := p; 2955 bhr.Prec := bhr.Prec + ( bhr.FDig - p ); 2956 end; 2957 if NOT pack_BCD ( bhr, BCDout ) 2958 then begin 2959 RAISE eBCDOverflowException.create ( 'in BCDAdd' ); 2960 end; 2961 end; 2962 2963 procedure BCDSubtract ( const BCDIn : tBCD; 2964 const IntIn : myInttype; 2965 var BCDout : tBCD ); 2966 2967{} 2968 var 2969 BCD : tBCD; 2970 bhr : tBCD_helper; 2971 p : {$ifopt r+} low ( bhr.FDig ) - 1..0 {$else} Integer {$endif}; 2972 ue : {$ifopt r+} 0..pred ( 100000000 ) {$else} Integer {$endif}; 2973 v : {$ifopt r+} -9..9 {$else} Integer {$endif}; 2974 direct : Boolean; 2975{} 2976 2977 begin 2978 if IntIn = 0 2979 then begin 2980 BCDout := BCDIn; 2981 EXIT; 2982 end; 2983 2984 if IntIn = low ( myInttype ) 2985 then begin 2986{$if declared ( myMinIntBCD ) } 2987 BCDSubtract ( BCDIn, myMinIntBCD, BCDout ); 2988 EXIT; 2989{$else} 2990 RAISE eBCDOverflowException.create ( 'in BCDSubtract' ); 2991{$endif} 2992 end; 2993 2994 if IsBCDNegative ( BCDIn ) 2995 then begin 2996 BCD := BCDIn; 2997 BCDNegate ( BCD ); 2998 if IntIn < 0 2999 then BCDSubtract ( BCD, -IntIn, BCDout ) 3000 else BCDAdd ( BCD, IntIn, BCDout ); 3001 BCDNegate ( BCDout ); 3002 EXIT; 3003 end; 3004 3005 if IntIn < 0 3006 then begin 3007 BCDAdd ( BCDIn, -IntIn, BCDout ); 3008 EXIT; 3009 end; 3010 3011 direct := False; 3012 case BCDIn.Precision 3013 - 3014{$ifndef bigger_BCD} 3015 ( BCDIn.SignSpecialPlaces AND PlacesMask ) 3016{$else} 3017 BCDIn.Places 3018{$endif} 3019 of 3020 2: direct := IntIn < 10; 3021 3: direct := IntIn < 100; 3022 4: direct := IntIn < 1000; 3023 5: direct := IntIn < 10000; 3024 6: direct := IntIn < 100000; 3025 7: direct := IntIn < 1000000; 3026 8: direct := IntIn < 10000000; 3027 9: direct := IntIn < 100000000; 3028 end; 3029{ 3030write(direct);dumpbcd(bcdin);write('[',intin,']'); 3031} 3032 if direct 3033 then begin 3034 unpack_BCD ( BCDIn, bhr ); 3035 WITH bhr do 3036 begin 3037 p := 0; 3038 ue := IntIn; 3039 while p >= FDig do 3040 begin 3041 v := Singles[p] - ue MOD 10; 3042 ue := ue DIV 10; 3043 if v < 0 3044 then begin 3045 v := v + 10; 3046 ue := ue + 1; 3047 end; 3048 Singles[p] := v; 3049 Dec ( p ); 3050 end; 3051 end; 3052 if NOT pack_BCD ( bhr, BCDout ) 3053 then begin 3054 RAISE eBCDOverflowException.create ( 'in BCDSubtract' ); 3055 end; 3056 end 3057 else 3058{} 3059 BCDSubtract ( BCDIn, IntegerToBCD ( IntIn ), BCDout ); 3060 end; 3061 3062 procedure BCDAdd ( const IntIn : myInttype; 3063 const BCDIn : tBCD; 3064 var BCDout : tBCD ); Inline; 3065 3066 begin 3067 BCDAdd ( BCDIn, IntIn, BCDout ); 3068 end; 3069 3070{$ifndef FPUNONE} 3071 procedure BCDAdd ( const BCDIn : tBCD; 3072 const DoubleIn : myRealtype; 3073 var BCDout : tBCD ); Inline; 3074 3075 begin 3076 BCDAdd ( BCDIn, DoubleToBCD ( DoubleIn ), BCDout ); 3077 end; 3078 3079 procedure BCDAdd ( const DoubleIn : myRealtype; 3080 const BCDIn : tBCD; 3081 var BCDout : tBCD ); Inline; 3082 3083 begin 3084 BCDAdd ( DoubleToBCD ( DoubleIn ), BCDIn, BCDout ); 3085 end; 3086{$endif} 3087 3088 procedure BCDAdd ( const BCDIn : tBCD; 3089 const Currin : currency; 3090 var BCDout : tBCD ); Inline; 3091 3092 begin 3093 BCDAdd ( BCDIn, CurrToBCD ( Currin ), BCDout ); 3094 end; 3095 3096 procedure BCDAdd ( const Currin : currency; 3097 const BCDIn : tBCD; 3098 var BCDout : tBCD ); Inline; 3099 3100 begin 3101 BCDAdd ( CurrToBCD ( Currin ), BCDIn, BCDout ); 3102 end; 3103 3104{$ifdef comproutines} 3105 procedure BCDAdd ( const BCDIn : tBCD; 3106 const Compin : Comp; 3107 var BCDout : tBCD ); Inline; 3108 3109 begin 3110 BCDAdd ( BCDIn, CompToBCD ( Compin ), BCDout ); 3111 end; 3112 3113 procedure BCDAdd ( const Compin : Comp; 3114 const BCDIn : tBCD; 3115 var BCDout : tBCD ); Inline; 3116 3117 begin 3118 BCDAdd ( CompToBCD ( Compin ), BCDIn, BCDout ); 3119 end; 3120{$endif} 3121 3122 procedure BCDAdd ( const BCDIn : tBCD; 3123 const StringIn : FmtBCDStringtype; 3124 var BCDout : tBCD ); Inline; 3125 3126 begin 3127 BCDAdd ( BCDIn, StrToBCD ( StringIn ), BCDout ); 3128 end; 3129 3130 procedure BCDAdd ( const StringIn : FmtBCDStringtype; 3131 const BCDIn : tBCD; 3132 var BCDout : tBCD ); Inline; 3133 3134 begin 3135 BCDAdd ( StrToBCD ( StringIn ), BCDIn, BCDout ); 3136 end; 3137 3138 procedure BCDAdd ( const StringIn1, 3139 StringIn2 : FmtBCDStringtype; 3140 var BCDout : tBCD ); Inline; 3141 3142 begin 3143 BCDAdd ( StrToBCD ( StringIn1 ), StrToBCD ( StringIn2 ), BCDout ); 3144 end; 3145 3146 procedure BCDSubtract ( const IntIn : myInttype; 3147 const BCDIn : tBCD; 3148 var BCDout : tBCD ); Inline; 3149 3150 begin 3151 BCDSubtract ( BCDIn, IntIn, BCDout ); 3152 BCDNegate ( BCDout ); 3153 end; 3154 3155{$ifndef FPUNONE} 3156 procedure BCDSubtract ( const BCDIn : tBCD; 3157 const DoubleIn : myRealtype; 3158 var BCDout : tBCD ); Inline; 3159 3160 begin 3161 BCDSubtract ( BCDIn, DoubleToBCD ( DoubleIn ), BCDout ); 3162 end; 3163 3164 procedure BCDSubtract ( const DoubleIn : myRealtype; 3165 const BCDIn : tBCD; 3166 var BCDout : tBCD ); Inline; 3167 3168 begin 3169 BCDSubtract ( DoubleToBCD ( DoubleIn ), BCDIn, BCDout ); 3170 end; 3171{$endif} 3172 3173 procedure BCDSubtract ( const BCDIn : tBCD; 3174 const Currin : currency; 3175 var BCDout : tBCD ); Inline; 3176 3177 begin 3178 BCDSubtract ( BCDIn, CurrToBCD ( Currin ), BCDout ); 3179 end; 3180 3181 procedure BCDSubtract ( const Currin : currency; 3182 const BCDIn : tBCD; 3183 var BCDout : tBCD ); Inline; 3184 3185 begin 3186 BCDSubtract ( CurrToBCD ( Currin ), BCDIn, BCDout ); 3187 end; 3188 3189{$ifdef comproutines} 3190 procedure BCDSubtract ( const BCDIn : tBCD; 3191 const Compin : Comp; 3192 var BCDout : tBCD ); Inline; 3193 3194 begin 3195 BCDSubtract ( BCDIn, CompToBCD ( Compin ), BCDout ); 3196 end; 3197 3198 procedure BCDSubtract ( const Compin : Comp; 3199 const BCDIn : tBCD; 3200 var BCDout : tBCD ); Inline; 3201 3202 begin 3203 BCDSubtract ( CompToBCD ( Compin ), BCDIn, BCDout ); 3204 end; 3205{$endif} 3206 3207 procedure BCDSubtract ( const BCDIn : tBCD; 3208 const StringIn : FmtBCDStringtype; 3209 var BCDout : tBCD ); Inline; 3210 3211 begin 3212 BCDSubtract ( BCDIn, StrToBCD ( StringIn ), BCDout ); 3213 end; 3214 3215 procedure BCDSubtract ( const StringIn : FmtBCDStringtype; 3216 const BCDIn : tBCD; 3217 var BCDout : tBCD ); Inline; 3218 3219 begin 3220 BCDSubtract ( StrToBCD ( StringIn ), BCDIn, BCDout ); 3221 end; 3222 3223 procedure BCDSubtract ( const StringIn1, 3224 StringIn2 : FmtBCDStringtype; 3225 var BCDout : tBCD ); Inline; 3226 3227 begin 3228 BCDSubtract ( StrToBCD ( StringIn1 ), StrToBCD ( StringIn2 ), BCDout ); 3229 end; 3230 3231 procedure BCDMultiply ( const BCDIn : tBCD; 3232 const IntIn : myInttype; 3233 var BCDout : tBCD ); 3234 3235 var 3236 bh : tBCD_helper; 3237 bhr : tBCD_helper; 3238 bhrr : tBCD_helper_big; 3239 int : {$ifopt r+} 0..high ( bhrr.Singles[0] ) DIV 10 {$else} Integer {$endif}; 3240 i1 : {$ifopt r+} low ( bh.Singles )..high ( bh.Singles ) {$else} Integer {$endif}; 3241 i3 : {$ifopt r+} low ( bhr.Singles )..high ( bhr.Singles ) {$else} Integer {$endif}; 3242 v : {$ifopt r+} low ( bhrr.Singles[0] ) + low ( bhrr.Singles[0] ) DIV 10..high ( bhrr.Singles[0] ) + high ( bhrr.Singles[0] ) DIV 10 {$else} Integer {$endif}; 3243 ue : {$ifopt r+} 1 * ( low ( bhrr.Singles[0] ) + low ( bhrr.Singles[0] ) DIV 10 ) DIV 10 3244 ..( high ( bhrr.Singles[0] ) + high ( bhrr.Singles[0] ) DIV 10 ) DIV 10 {$else} Integer {$endif}; 3245 3246 begin 3247 if IntIn = 0 3248 then begin 3249 BCDout := NullBCD; 3250 EXIT; 3251 end; 3252 3253 if IntIn = 1 3254 then begin 3255 BCDout := BCDIn; 3256 EXIT; 3257 end; 3258 3259 if IntIn = -1 3260 then begin 3261 BCDout := BCDIn; 3262 BCDNegate ( BCDout ); 3263 EXIT; 3264 end; 3265 3266 if IntIn = low ( myInttype ) 3267 then begin 3268{$if declared ( myMinIntBCD ) } 3269 BCDMultiply ( BCDIn, myMinIntBCD, BCDout ); 3270 EXIT; 3271{$else} 3272 RAISE eBCDOverflowException.create ( 'in BCDmultiply' ); 3273{$endif} 3274 end; 3275 3276 if Abs ( IntIn ) > low ( bhrr.Singles[0] ) DIV 10 3277 then begin 3278 BCDMultiply ( BCDIn, IntegerToBCD ( IntIn ), BCDout ); 3279 EXIT; 3280 end; 3281 3282 unpack_BCD ( BCDIn, bh ); 3283 if bh.Prec = 0 3284 then begin 3285 BCDout := NullBCD; 3286 EXIT; 3287 end; 3288 3289 bhr := null_.bh; 3290 bhrr := null_.bhb; 3291 int := Abs ( IntIn ); 3292 WITH bhrr do 3293 begin 3294 Neg := bh.Neg XOR ( IntIn < 0 ); 3295 FDig := bh.FDig; 3296 LDig := bh.LDig; 3297 for i1 := bh.FDig TO bh.LDig do 3298 Singles[i1] := bh.Singles[i1] * int; 3299{ 3300for i3 := fdig to ldig do 3301 write ( ' ', singles[i3] ); 3302writeln; 3303} 3304 ue := 0; 3305 for i3 := LDig DOWNTO FDig do 3306 begin 3307 v := Singles[i3] + ue; 3308 ue := v DIV 10; 3309 v := v MOD 10; 3310 bhr.Singles[i3] := v; 3311 end; 3312 while ue <> 0 do 3313 begin 3314 Dec ( FDig ); 3315 if FDig < low ( bhr.Singles ) 3316 then RAISE eBCDOverflowException.create ( 'in BCDMultiply' ); 3317 bhr.Singles[FDig] := ue MOD 10; 3318 ue := ue DIV 10; 3319 end; 3320 bhr.Plac := LDig; 3321 bhr.FDig := FDig; 3322 if LDig > high ( bhr.Singles ) 3323 then bhr.LDig := high ( bhr.Singles ) 3324 else bhr.LDig := LDig; 3325 end; 3326 if NOT pack_BCD ( bhr, BCDout ) 3327 then begin 3328 RAISE eBCDOverflowException.create ( 'in BCDMultiply' ); 3329 end; 3330 end; 3331 3332 procedure BCDMultiply ( const IntIn : myInttype; 3333 const BCDIn : tBCD; 3334 var BCDout : tBCD ); Inline; 3335 3336 begin 3337 BCDMultiply ( BCDIn, IntIn, BCDout ); 3338 end; 3339 3340{$ifndef FPUNONE} 3341 procedure BCDMultiply ( const DoubleIn : myRealtype; 3342 const BCDIn : tBCD; 3343 var BCDout : tBCD ); Inline; 3344 3345 begin 3346 BCDMultiply ( DoubleToBCD ( DoubleIn ), BCDIn, BCDout ); 3347 end; 3348{$endif} 3349 3350 procedure BCDMultiply ( const BCDIn : tBCD; 3351 const Currin : currency; 3352 var BCDout : tBCD ); Inline; 3353 3354 begin 3355 BCDMultiply ( BCDIn, CurrToBCD ( Currin ), BCDout ); 3356 end; 3357 3358 procedure BCDMultiply ( const Currin : currency; 3359 const BCDIn : tBCD; 3360 var BCDout : tBCD ); Inline; 3361 3362 begin 3363 BCDMultiply ( CurrToBCD ( Currin ), BCDIn, BCDout ); 3364 end; 3365 3366{$ifdef comproutines} 3367 procedure BCDMultiply ( const BCDIn : tBCD; 3368 const Compin : Comp; 3369 var BCDout : tBCD ); Inline; 3370 3371 begin 3372 BCDMultiply ( BCDIn, CompToBCD ( Compin ), BCDout ); 3373 end; 3374 3375 procedure BCDMultiply ( const Compin : Comp; 3376 const BCDIn : tBCD; 3377 var BCDout : tBCD ); Inline; 3378 3379 begin 3380 BCDMultiply ( CompToBCD ( Compin ), BCDIn, BCDout ); 3381 end; 3382{$endif} 3383 3384 procedure BCDMultiply ( const StringIn : FmtBCDStringtype; 3385 const BCDIn : tBCD; 3386 var BCDout : tBCD ); Inline; 3387 3388 begin 3389 BCDMultiply ( StrToBCD ( StringIn ), BCDIn, BCDout ); 3390 end; 3391 3392 procedure BCDDivide ( const Dividend : tBCD; 3393 const Divisor : myInttype; 3394 var BCDout : tBCD ); Inline; 3395 3396 begin 3397 BCDDivide ( Dividend, IntegerToBCD ( Divisor ), BCDout ); 3398 end; 3399 3400 procedure BCDDivide ( const Dividend : myInttype; 3401 const Divisor : tBCD; 3402 var BCDout : tBCD ); Inline; 3403 3404 begin 3405 BCDDivide ( IntegerToBCD ( Dividend ), Divisor, BCDout ); 3406 end; 3407 3408{$ifndef FPUNONE} 3409 procedure BCDDivide ( const Dividend : myRealtype; 3410 const Divisor : tBCD; 3411 var BCDout : tBCD ); Inline; 3412 3413 begin 3414 BCDDivide ( DoubleToBCD ( Dividend ), Divisor, BCDout ); 3415 end; 3416{$endif} 3417 3418 procedure BCDDivide ( const BCDIn : tBCD; 3419 const Currin : currency; 3420 var BCDout : tBCD ); Inline; 3421 3422 begin 3423 BCDDivide ( BCDIn, CurrToBCD ( Currin ), BCDout ); 3424 end; 3425 3426 procedure BCDDivide ( const Currin : currency; 3427 const BCDIn : tBCD; 3428 var BCDout : tBCD ); Inline; 3429 3430 begin 3431 BCDDivide ( CurrToBCD ( Currin ), BCDIn, BCDout ); 3432 end; 3433 3434{$ifdef comproutines} 3435 procedure BCDDivide ( const BCDIn : tBCD; 3436 const Compin : Comp; 3437 var BCDout : tBCD ); Inline; 3438 3439 begin 3440 BCDDivide ( BCDIn, CompToBCD ( Compin ), BCDout ); 3441 end; 3442 3443 procedure BCDDivide ( const Compin : Comp; 3444 const BCDIn : tBCD; 3445 var BCDout : tBCD ); Inline; 3446 3447 begin 3448 BCDDivide ( CompToBCD ( Compin ), BCDIn, BCDout ); 3449 end; 3450{$endif} 3451 3452 procedure BCDDivide ( const Dividend : FmtBCDStringtype; 3453 const Divisor : tBCD; 3454 var BCDout : tBCD ); Inline; 3455 3456 begin 3457 BCDDivide ( StrToBCD ( Dividend ), Divisor, BCDout ); 3458 end; 3459 3460 operator = ( const BCD1, 3461 BCD2 : tBCD ) z : Boolean; Inline; 3462 3463 begin 3464 z := BCDCompare ( BCD1, BCD2 ) = 0; 3465 end; 3466 3467 operator < ( const BCD1, 3468 BCD2 : tBCD ) z : Boolean; Inline; 3469 3470 begin 3471 z := BCDCompare ( BCD1, BCD2 ) < 0; 3472 end; 3473 3474 operator > ( const BCD1, 3475 BCD2 : tBCD ) z : Boolean; Inline; 3476 3477 begin 3478 z := BCDCompare ( BCD1, BCD2 ) > 0; 3479 end; 3480 3481 operator <= ( const BCD1, 3482 BCD2 : tBCD ) z : Boolean; Inline; 3483 3484 begin 3485 z := BCDCompare ( BCD1, BCD2 ) <= 0; 3486 end; 3487 3488 operator >= ( const BCD1, 3489 BCD2 : tBCD ) z : Boolean; Inline; 3490 3491 begin 3492 z := BCDCompare ( BCD1, BCD2 ) >= 0; 3493 end; 3494 3495(* ######################## not allowed: why? 3496 operator + ( const BCD : tBCD ) z : tBCD; Inline; 3497 3498 begin 3499 z := bcd; 3500 end; 3501##################################################### *) 3502 3503 operator - ( const BCD : tBCD ) z : tBCD; Inline; 3504 3505 begin 3506 z := BCD; 3507 BCDNegate ( z ); 3508 end; 3509 3510 operator + ( const BCD1, 3511 BCD2 : tBCD ) z : tBCD; Inline; 3512 3513 begin 3514 BCDAdd ( BCD1, BCD2, z ); 3515 end; 3516 3517 operator + ( const BCD : tBCD; 3518 const i : myInttype ) z : tBCD; Inline; 3519 3520 begin 3521 BCDAdd ( BCD, i, z ); 3522 end; 3523 3524 operator + ( const i : myInttype; 3525 const BCD : tBCD ) z : tBCD; Inline; 3526 3527 begin 3528 BCDAdd ( i, BCD, z ); 3529 end; 3530 3531{$ifndef FPUNONE} 3532 operator + ( const BCD : tBCD; 3533 const r : myRealtype ) z : tBCD; Inline; 3534 3535 begin 3536 BCDAdd ( BCD, DoubleToBCD ( r ), z ); 3537 end; 3538 3539 operator + ( const r : myRealtype; 3540 const BCD : tBCD ) z : tBCD; Inline; 3541 3542 begin 3543 BCDAdd ( DoubleToBCD ( r ), BCD, z ); 3544 end; 3545{$endif} 3546 3547 operator + ( const BCD : tBCD; 3548 const c : currency ) z : tBCD; Inline; 3549 3550 begin 3551 BCDAdd ( BCD, CurrToBCD ( c ), z ); 3552 end; 3553 3554 operator + ( const c : currency; 3555 const BCD : tBCD ) z : tBCD; Inline; 3556 3557 begin 3558 BCDAdd ( CurrToBCD ( c ), BCD, z ); 3559 end; 3560 3561{$ifdef comproutines} 3562 operator + ( const BCD : tBCD; 3563 const c : Comp ) z : tBCD; Inline; 3564 3565 begin 3566 BCDAdd ( BCD, CompToBCD ( c ), z ); 3567 end; 3568 3569 operator + ( const c : Comp; 3570 const BCD : tBCD ) z : tBCD; Inline; 3571 3572 begin 3573 BCDAdd ( CompToBCD ( c ), BCD, z ); 3574 end; 3575{$endif} 3576 3577 operator + ( const BCD : tBCD; 3578 const s : FmtBCDStringtype ) z : tBCD; Inline; 3579 3580 begin 3581 BCDAdd ( BCD, StrToBCD ( s ), z ); 3582 end; 3583 3584 operator + ( const s : FmtBCDStringtype; 3585 const BCD : tBCD ) z : tBCD; Inline; 3586 3587 begin 3588 BCDAdd ( StrToBCD ( s ), BCD, z ); 3589 end; 3590 3591 operator - ( const BCD1, 3592 BCD2 : tBCD ) z : tBCD; Inline; 3593 3594 begin 3595 BCDSubtract ( BCD1, BCD2, z ); 3596 end; 3597 3598 operator - ( const BCD : tBCD; 3599 const i : myInttype ) z : tBCD; Inline; 3600 3601 begin 3602 BCDSubtract ( BCD, i, z ); 3603 end; 3604 3605 operator - ( const i : myInttype; 3606 const BCD : tBCD ) z : tBCD; Inline; 3607 3608 begin 3609 BCDSubtract ( BCD, i, z ); 3610 BCDNegate ( z ); 3611 end; 3612 3613{$ifndef FPUNONE} 3614 operator - ( const BCD : tBCD; 3615 const r : myRealtype ) z : tBCD; Inline; 3616 3617 begin 3618 BCDSubtract ( BCD, DoubleToBCD ( r ), z ); 3619 end; 3620 3621 operator - ( const r : myRealtype; 3622 const BCD : tBCD ) z : tBCD; Inline; 3623 3624 begin 3625 BCDSubtract ( DoubleToBCD ( r ), BCD, z ); 3626 end; 3627{$endif} 3628 3629 operator - ( const BCD : tBCD; 3630 const c : currency ) z : tBCD; Inline; 3631 3632 begin 3633 BCDSubtract ( BCD, CurrToBCD ( c ), z ); 3634 end; 3635 3636 operator - ( const c : currency; 3637 const BCD : tBCD ) z : tBCD; Inline; 3638 3639 begin 3640 BCDSubtract ( CurrToBCD ( c ), BCD, z ); 3641 end; 3642 3643{$ifdef comproutines} 3644 operator - ( const BCD : tBCD; 3645 const c : Comp ) z : tBCD; Inline; 3646 3647 begin 3648 BCDSubtract ( BCD, CompToBCD ( c ), z ); 3649 end; 3650 3651 operator - ( const c : Comp; 3652 const BCD : tBCD ) z : tBCD; Inline; 3653 3654 begin 3655 BCDSubtract ( CompToBCD ( c ), BCD, z ); 3656 end; 3657{$endif} 3658 3659 operator - ( const BCD : tBCD; 3660 const s : FmtBCDStringtype ) z : tBCD; Inline; 3661 3662 begin 3663 BCDSubtract ( BCD, StrToBCD ( s ), z ); 3664 end; 3665 3666 operator - ( const s : FmtBCDStringtype; 3667 const BCD : tBCD ) z : tBCD; Inline; 3668 3669 begin 3670 BCDSubtract ( StrToBCD ( s ), BCD, z ); 3671 end; 3672 3673 operator * ( const BCD1, 3674 BCD2 : tBCD ) z : tBCD; Inline; 3675 3676 begin 3677 BCDMultiply ( BCD1, BCD2, z ); 3678 end; 3679 3680 operator * ( const BCD : tBCD; 3681 const i : myInttype ) z : tBCD; Inline; 3682 3683 begin 3684 BCDMultiply ( BCD, i, z ); 3685 end; 3686 3687 operator * ( const i : myInttype; 3688 const BCD : tBCD ) z : tBCD; Inline; 3689 3690 begin 3691 BCDMultiply ( BCD, i, z ); 3692 end; 3693 3694{$ifndef FPUNONE} 3695 operator * ( const BCD : tBCD; 3696 const r : myRealtype ) z : tBCD; Inline; 3697 3698 begin 3699 BCDMultiply ( BCD, DoubleToBCD ( r ), z ); 3700 end; 3701 3702 operator * ( const r : myRealtype; 3703 const BCD : tBCD ) z : tBCD; Inline; 3704 3705 begin 3706 BCDMultiply ( DoubleToBCD ( r ), BCD, z ); 3707 end; 3708{$endif} 3709 3710 operator * ( const BCD : tBCD; 3711 const c : currency ) z : tBCD; Inline; 3712 3713 begin 3714 BCDMultiply ( BCD, CurrToBCD ( c ), z ); 3715 end; 3716 3717 operator * ( const c : currency; 3718 const BCD : tBCD ) z : tBCD; Inline; 3719 3720 begin 3721 BCDMultiply ( CurrToBCD ( c ), BCD, z ); 3722 end; 3723 3724{$ifdef comproutines} 3725 operator * ( const BCD : tBCD; 3726 const c : Comp ) z : tBCD; Inline; 3727 3728 begin 3729 BCDMultiply ( BCD, CompToBCD ( c ), z ); 3730 end; 3731 3732 operator * ( const c : Comp; 3733 const BCD : tBCD ) z : tBCD; Inline; 3734 3735 begin 3736 BCDMultiply ( CompToBCD ( c ), BCD, z ); 3737 end; 3738{$endif} 3739 3740 operator * ( const BCD : tBCD; 3741 const s : FmtBCDStringtype ) z : tBCD; Inline; 3742 3743 begin 3744 BCDMultiply ( BCD, StrToBCD ( s ), z ); 3745 end; 3746 3747 operator * ( const s : FmtBCDStringtype; 3748 const BCD : tBCD ) z : tBCD; Inline; 3749 3750 begin 3751 BCDMultiply ( StrToBCD ( s ), BCD, z ); 3752 end; 3753 3754 operator / ( const BCD1, 3755 BCD2 : tBCD ) z : tBCD; Inline; 3756 3757 begin 3758 BCDDivide ( BCD1, BCD2, z ); 3759 end; 3760 3761 operator / ( const BCD : tBCD; 3762 const i : myInttype ) z : tBCD; Inline; 3763 3764 begin 3765 BCDDivide ( BCD, i, z ); 3766 end; 3767 3768 operator / ( const i : myInttype; 3769 const BCD : tBCD ) z : tBCD; Inline; 3770 3771 begin 3772 BCDDivide ( IntegerToBCD ( i ), BCD, z ); 3773 end; 3774 3775{$ifndef FPUNONE} 3776 operator / ( const BCD : tBCD; 3777 const r : myRealtype ) z : tBCD; Inline; 3778 3779 begin 3780 BCDDivide ( BCD, DoubleToBCD ( r ), z ); 3781 end; 3782 3783 operator / ( const r : myRealtype; 3784 const BCD : tBCD ) z : tBCD; Inline; 3785 3786 begin 3787 BCDDivide ( DoubleToBCD ( r ), BCD, z ); 3788 end; 3789{$endif} 3790 3791 operator / ( const BCD : tBCD; 3792 const c : currency ) z : tBCD; Inline; 3793 3794 begin 3795 BCDDivide ( BCD, CurrToBCD ( c ), z ); 3796 end; 3797 3798 operator / ( const c : currency; 3799 const BCD : tBCD ) z : tBCD; Inline; 3800 3801 begin 3802 BCDDivide ( CurrToBCD ( c ), BCD, z ); 3803 end; 3804 3805{$ifdef comproutines} 3806 operator / ( const BCD : tBCD; 3807 const c : Comp ) z : tBCD; Inline; 3808 3809 begin 3810 BCDDivide ( BCD, CompToBCD ( c ), z ); 3811 end; 3812 3813 operator / ( const c : Comp; 3814 const BCD : tBCD ) z : tBCD; Inline; 3815 3816 begin 3817 BCDDivide ( CompToBCD ( c ), BCD, z ); 3818 end; 3819{$endif} 3820 3821 operator / ( const BCD : tBCD; 3822 const s : FmtBCDStringtype ) z : tBCD; Inline; 3823 3824 begin 3825 BCDDivide ( BCD, StrToBCD ( s ), z ); 3826 end; 3827 3828 operator / ( const s : FmtBCDStringtype; 3829 const BCD : tBCD ) z : tBCD; Inline; 3830 3831 begin 3832 BCDDivide ( StrToBCD ( s ), BCD, z ); 3833 end; 3834 3835 operator := ( const i : Byte ) z : tBCD; Inline; 3836 3837 begin 3838 z := IntegerToBCD ( myInttype ( i ) ); 3839 end; 3840 3841 operator := ( const BCD : tBCD ) z : Byte; Inline; 3842 3843 begin 3844 z := BCDToInteger ( BCD ); 3845 end; 3846 3847 operator := ( const i : Word ) z : tBCD; Inline; 3848 3849 begin 3850 z := IntegerToBCD ( myInttype ( i ) ); 3851 end; 3852 3853 operator := ( const BCD : tBCD ) z : Word; Inline; 3854 3855 begin 3856 z := BCDToInteger ( BCD ); 3857 end; 3858 3859 operator := ( const i : longword ) z : tBCD; Inline; 3860 3861 begin 3862 z := IntegerToBCD ( myInttype ( i ) ); 3863 end; 3864 3865 operator := ( const BCD : tBCD ) z : longword; Inline; 3866 3867 begin 3868 z := BCDToInteger ( BCD ); 3869 end; 3870 3871{$if declared ( qword ) } 3872 operator := ( const i : qword ) z : tBCD; Inline; 3873 3874 begin 3875 z := IntegerToBCD ( myInttype ( i ) ); 3876 end; 3877 3878 operator := ( const BCD : tBCD ) z : qword; Inline; 3879 3880 begin 3881 z := BCDToInteger ( BCD ); 3882 end; 3883{$endif} 3884 3885 operator := ( const i : ShortInt ) z : tBCD; Inline; 3886 3887 begin 3888 z := IntegerToBCD ( myInttype ( i ) ); 3889 end; 3890 3891 operator := ( const BCD : tBCD ) z : ShortInt; Inline; 3892 3893 begin 3894 z := BCDToInteger ( BCD ); 3895 end; 3896 3897 operator := ( const i : smallint ) z : tBCD; Inline; 3898 3899 begin 3900 z := IntegerToBCD ( myInttype ( i ) ); 3901 end; 3902 3903 operator := ( const BCD : tBCD ) z : smallint; Inline; 3904 3905 begin 3906 z := BCDToInteger ( BCD ); 3907 end; 3908 3909 operator := ( const i : LongInt ) z : tBCD; Inline; 3910 3911 begin 3912 z := IntegerToBCD ( myInttype ( i ) ); 3913 end; 3914 3915 operator := ( const BCD : tBCD ) z : LongInt; Inline; 3916 3917 begin 3918 z := BCDToInteger ( BCD ); 3919 end; 3920 3921{$if declared ( int64 ) } 3922 operator := ( const i : int64 ) z : tBCD; Inline; 3923 3924 begin 3925 z := IntegerToBCD ( myInttype ( i ) ); 3926 end; 3927 3928 operator := ( const BCD : tBCD ) z : int64; Inline; 3929 3930 begin 3931 z := BCDToInteger ( BCD ); 3932 end; 3933{$endif} 3934 3935{$ifndef FPUNONE} 3936 operator := ( const r : Single ) z : tBCD; Inline; 3937 3938 begin 3939 z := DoubleToBCD ( myRealtype ( r ) ); 3940 end; 3941 3942 operator := ( const BCD : tBCD ) z : Single; Inline; 3943 3944 begin 3945 z := BCDToDouble ( BCD ); 3946 end; 3947 3948 operator := ( const r : Double ) z : tBCD; Inline; 3949 3950 begin 3951 z := DoubleToBCD ( myRealtype ( r ) ); 3952 end; 3953 3954 operator := ( const BCD : tBCD ) z : Double; Inline; 3955 3956 begin 3957 z := BCDToDouble ( BCD ); 3958 end; 3959 3960{$if sizeof ( extended ) <> sizeof ( double )} 3961 operator := ( const r : Extended ) z : tBCD; Inline; 3962 3963 begin 3964 z := DoubleToBCD ( {myRealtype (} r {)} ); 3965 end; 3966 3967 operator := ( const BCD : tBCD ) z : Extended; Inline; 3968 3969 begin 3970 z := BCDToDouble ( BCD ); 3971 end; 3972{$endif} 3973{$endif} 3974 3975 operator := ( const c : currency ) z : tBCD; Inline; 3976 3977 begin 3978 CurrToBCD ( c, z ); 3979 end; 3980 3981 operator := ( const BCD : tBCD ) z : currency; Inline; 3982 3983 begin 3984 BCDToCurr ( BCD, z ); 3985 end; 3986 3987{$ifdef comproutines} 3988 3989{$undef makedirect} 3990 3991{$ifdef makedirect} 3992 operator := ( const c : Comp ) z : tBCD; Inline; 3993 3994 var 3995 cc : int64 absolute c; 3996 3997 begin 3998 z := IntegerToBCD ( cc ); 3999 end; 4000 4001{ $define version1} { only one of these may be defined! } 4002{ $define version2} { version 1 produces a compiler error (with INLINE only!)} 4003{$define version3} { I wasn't able to reduce the problem, sorry } 4004 4005{$ifdef version1} 4006 operator := ( const BCD : tBCD ) z : Comp; Inline; 4007 4008 var 4009 zz : Comp absolute z; 4010 4011 begin 4012 zz := BCDToInteger ( BCD ); 4013 end; 4014{$endif} 4015 4016{$ifdef version2} 4017 operator := ( const BCD : tBCD ) z : Comp; Inline; 4018 4019 var 4020 zz : int64; 4021 zzz : Comp absolute zz; 4022 4023 begin 4024 zz := BCDToInteger ( BCD ); 4025 z := zzz; 4026 end; 4027{$endif} 4028 4029{$ifdef version3} 4030 operator := ( const BCD : tBCD ) z : Comp; Inline; 4031 4032 var 4033 zz : record 4034 case Boolean of 4035 False: ( i : int64 ); 4036 True: ( c : Comp ); 4037 end; 4038 4039 begin 4040 zz.i := BCDToInteger ( BCD ); 4041 z := zz.c; 4042 end; 4043{$endif} 4044 4045{$else} 4046 operator := ( const c : Comp ) z : tBCD; Inline; 4047 4048 begin 4049 z := CompToBCD ( c ); 4050 end; 4051 4052 operator := ( const BCD : tBCD ) z : Comp; Inline; 4053 4054 begin 4055 z := BCDToComp ( BCD ); 4056 end; 4057{$endif} 4058 4059{$endif} 4060 4061 operator := ( const s : string ) z : tBCD; Inline; 4062 4063 begin 4064 z := StrToBCD ( s ); 4065 end; 4066 4067 operator := ( const BCD : tBCD ) z : string; Inline; 4068 4069 begin 4070 z := BCDToStr ( BCD ); 4071 end; 4072 4073 operator := ( const s : AnsiString ) z : tBCD; Inline; 4074 4075 begin 4076 z := StrToBCD ( s ); 4077 end; 4078 4079 operator := ( const BCD : tBCD ) z : AnsiString; Inline; 4080 4081 begin 4082 z := BCDToStr ( BCD ); 4083 end; 4084 4085{$endif} 4086 4087 4088Function VariantToBCD(const VargSrc : TVarData) : TBCD; 4089begin 4090 with VargSrc do 4091 case vType and not varTypeMask of 4092 0: case vType of 4093 varEmpty : Result := 0; 4094 varSmallInt : Result := vSmallInt; 4095 varShortInt : Result := vShortInt; 4096 varInteger : Result := vInteger; 4097 varSingle : Result := vSingle; 4098 varDouble : Result := vDouble; 4099 varCurrency : Result := vCurrency; 4100 varDate : Result := vDate; 4101 varBoolean : Result := Integer(vBoolean); 4102 varVariant : Result := VariantToBCD(PVarData(vPointer)^); 4103 varByte : Result := vByte; 4104 varWord : Result := vWord; 4105 varLongWord : Result := vLongWord; 4106 varInt64 : Result := vInt64; 4107 varQword : Result := vQWord; 4108 varString : Result := AnsiString(vString); 4109 varOleStr : Result := WideString(vOleStr); 4110 varUString : Result := UnicodeString(vString); 4111 else 4112 if vType=VarFmtBCD then 4113 Result := TFMTBcdVarData(vPointer).BCD 4114 else 4115 not_implemented; 4116 end; 4117 varByRef: if Assigned(vPointer) then case vType and varTypeMask of 4118 varSmallInt : Result := PSmallInt(vPointer)^; 4119 varShortInt : Result := PShortInt(vPointer)^; 4120 varInteger : Result := PInteger(vPointer)^; 4121 varSingle : Result := PSingle(vPointer)^; 4122 varDouble : Result := PDouble(vPointer)^; 4123 varCurrency : Result := PCurrency(vPointer)^; 4124 varDate : Result := PDate(vPointer)^; 4125 varBoolean : Result := SmallInt(PWordBool(vPointer)^); 4126 varVariant : Result := VariantToBCD(PVarData(vPointer)^); 4127 varByte : Result := PByte(vPointer)^; 4128 varWord : Result := PWord(vPointer)^; 4129 varLongWord : Result := PLongWord(vPointer)^; 4130 varInt64 : Result := PInt64(vPointer)^; 4131 varQword : Result := PQWord(vPointer)^; 4132 else { other vtype } 4133 not_implemented; 4134 end else { pointer is nil } 4135 not_implemented; 4136 else { array or something like that } 4137 not_implemented; 4138 end; 4139end; 4140 4141function VarToBCD ( const aValue : Variant ) : tBCD; 4142 begin 4143 Result:=VariantToBCD(TVarData(aValue)); 4144 end; 4145 4146 4147constructor TFMTBcdVarData.create; 4148 begin 4149 inherited create; 4150 FBcd:=NullBCD; 4151 end; 4152 4153constructor TFMTBcdVarData.create(const BCD : tBCD); 4154 begin 4155 inherited create; 4156 FBcd:=BCD; 4157 end; 4158 4159function TFMTBcdFactory.GetInstance(const v : TVarData): tObject; 4160 begin 4161 result:=tObject(v.VPointer); 4162 end; 4163 4164 4165procedure TFMTBcdFactory.BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp); 4166 var l, r: TBCD; 4167 begin 4168 l:=VariantToBCD(Left); 4169 r:=VariantToBCD(Right); 4170 4171 case Operation of 4172 opAdd: 4173 l:=l+r; 4174 opSubtract: 4175 l:=l-r; 4176 opMultiply: 4177 l:=l*r; 4178 opDivide: 4179 l:=l/r; 4180 else 4181 RaiseInvalidOp; 4182 end; 4183 4184 if Left.vType = VarType then 4185 TFMTBcdVarData(Left.VPointer).BCD := l 4186 else if Left.vType = varDouble then 4187 Left.vDouble := l 4188 else 4189 RaiseInvalidOp; 4190 end; 4191 4192procedure TFMTBcdFactory.Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult); 4193 var l, r: TBCD; 4194 CmpRes: integer; 4195 begin 4196 l:=VariantToBCD(Left); 4197 r:=VariantToBCD(Right); 4198 4199 CmpRes := BCDCompare(l,r); 4200 if CmpRes=0 then 4201 Relationship := crEqual 4202 else if CmpRes<0 then 4203 Relationship := crLessThan 4204 else 4205 Relationship := crGreaterThan; 4206 end; 4207 4208function TFMTBcdFactory.CompareOp(const Left, Right: TVarData; const Operation: TVarOp): Boolean; 4209 var l, r: TBCD; 4210 begin 4211 l:=VariantToBCD(Left); 4212 r:=VariantToBCD(Right); 4213 4214 case Operation of 4215 opCmpEq: 4216 Result := l=r; 4217 opCmpNe: 4218 Result := l<>r; 4219 opCmpLt: 4220 Result := l<r; 4221 opCmpLe: 4222 Result := l<=r; 4223 opCmpGt: 4224 Result := l>r; 4225 opCmpGe: 4226 Result := l>=r; 4227 else 4228 RaiseInvalidOp; 4229 end; 4230 end; 4231 4232procedure TFMTBcdFactory.Clear(var V: TVarData); 4233 begin 4234 FreeAndNil(tObject(V.VPointer)); 4235 V.VType:=varEmpty; 4236 end; 4237 4238procedure TFMTBcdFactory.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); 4239 begin 4240 if Indirect then 4241 Dest.VPointer:=Source.VPointer 4242 else 4243 Dest.VPointer:=TFMTBcdVarData.Create(TFMTBcdVarData(Source.VPointer).BCD); 4244 Dest.VType:=VarType; 4245 end; 4246 4247procedure TFMTBcdFactory.Cast(var Dest: TVarData; const Source: TVarData); 4248begin 4249 not_implemented; 4250end; 4251 4252procedure TFMTBcdFactory.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); 4253var v: TVarData; 4254begin 4255 if Source.vType=VarType then 4256 if aVarType = varString then 4257 VarDataFromStr(Dest, BCDToStr(TFMTBcdVarData(Source.vPointer).BCD)) 4258 else 4259 begin 4260 VarDataInit(v); 4261 v.vType:=varDouble; 4262 v.vDouble:=BCDToDouble(TFMTBcdVarData(Source.vPointer).BCD); 4263 VarDataCastTo(Dest, v, aVarType); //now cast Double to any requested type 4264 { finalizing v is not necessary here (Double is a simple type) } 4265 end 4266 else 4267 inherited; 4268end; 4269 4270{$if declared ( myMinIntBCD ) } 4271(* 4272 {$if sizeof ( integer ) = 2 } 4273 {$ifdef BCDgr4 } 4274 4275 const 4276 myMinIntBCDValue : packed array [ 1..3 ] of Char = #$32#$76#$80; 4277 4278 {$endif} 4279 {$else} 4280 {$if sizeof ( integer ) = 4 } 4281*) 4282 {$ifdef BCDgr9 } 4283 4284 const 4285 myMinIntBCDValue : packed array [ 1..10 ] of Char = #$21#$47#$48#$36#$48; 4286 4287 {$endif} 4288(* 4289 {$else} 4290 {$if sizeof ( integer ) = 8 } 4291 {$ifdef BCDgr18 } 4292 4293 const 4294 myMinIntBCDValue : packed array [ 1..19 ] of Char = #$92#$23#$37#$20#$36#$85#$47#$75#$80#$80; 4295 4296 {$endif} 4297 {$else} 4298 {$fatal You have an interesting integer type! Sorry, not supported} 4299 {$endif} 4300 {$endif} 4301 {$endif} 4302*) 4303{$endif} 4304 4305initialization 4306 FillChar ( null_, SizeOf ( null_ ), #0 ); 4307 FillChar ( NullBCD_, SizeOf ( NullBCD_ ), #0 ); 4308 FillChar ( OneBCD_, SizeOf ( OneBCD_ ), #0 ); 4309 OneBCD_.Precision := 1; 4310 OneBCD_.Fraction[low ( OneBCD_.Fraction )] := $10; 4311 4312{$if declared ( myMinIntBCD ) } 4313 4314 FillChar ( myMinIntBCD, SizeOf ( myMinIntBCD ), #0 ); 4315{$ifndef bigger_BCD} 4316 myMinIntBCD.SignSpecialPlaces := NegBit; 4317{$else} 4318 myMinIntBCD.Negativ := True; 4319{$endif} 4320 4321 {$if sizeof ( integer ) = 2 } 4322 {$ifdef BCDgr4 } 4323 4324 myMinIntBCD.Precision := 5; 4325 Move ( myMinIntBCDValue, myMinIntBCD.Fraction, SizeOf ( myMinIntBCDValue ) ); 4326 4327 {$endif} 4328 {$else} 4329 {$if sizeof ( integer ) = 4 } 4330 {$ifdef BCDgr9 } 4331 4332 myMinIntBCD.Precision := 10; 4333 Move ( myMinIntBCDValue, myMinIntBCD.Fraction, SizeOf ( myMinIntBCDValue ) ); 4334 4335 {$endif} 4336 {$else} 4337 {$if sizeof ( integer ) = 8 } 4338 {$ifdef BCDgr18 } 4339 4340 myMinIntBCD.Precision := 19; 4341 Move ( myMinIntBCDValue, myMinIntBCD.Fraction, SizeOf ( myMinIntBCDValue ) ); 4342 4343 {$endif} 4344 {$else} 4345 {$fatal You have an interesting integer type! Sorry, not supported} 4346 {$endif} 4347 {$endif} 4348 {$endif} 4349{$endif} 4350 4351 FMTBcdFactory:=TFMTBcdFactory.create; 4352finalization 4353 FreeAndNil(FMTBcdFactory) 4354end. 4355