* Patch from Lacak to add support for densely packed decimal64 format

packages/rtl-objpas/src/inc/fmtbcd.pp

@@ -350,6 +350,8 @@ INTERFACE
 
   function Int128ToBCD ( const aValue : Int128Rec ) : tBCD;
 
+  function DPDec64ToBCD ( const aValue : QWord ) : tBCD;
+
   function VarToBCD ( const aValue : Variant ) : tBCD;
 
 { From DB.pas }
@@ -373,6 +375,8 @@ INTERFACE
 
   function BCDToInt128 ( const BCD : tBCD ) : Int128Rec;
 
+  function BCDToDPDec64 ( const BCD : tBCD ) : QWord;
+
 { From DB.pas }
   function BCDToCurr ( const BCD : tBCD;
                          var Curr : currency ) : Boolean;
@@ -1716,6 +1720,97 @@ IMPLEMENTATION
     end;
   end;
 
+
+  { Convert IEEE 754 Densely packed decimal64 format to BCD struct }
+
+  function DPDec64ToBCD ( const aValue : QWord ) : tBCD;
+
+  var
+    bh : tBCD_helper;
+    combination, exponent, leading_digit: DWord;
+    significand: QWord;
+    p : Integer;
+    declet,a,b: Word;
+    c0,c1,c2,d0,d1,d2: Byte;
+
+  begin
+    bh := null_.bh;
+    // Decimal64 supports values that can have 16 digit precision
+    // Sign: 1 bit, Combination: 13 bits, Significand continuation: 50 bits
+    // (−1)^Sign * 10^Exponent−398 * Significand
+    // (Binary encoding or Decimal encoding)
+    combination := aValue shr 50;
+    bh.Neg := combination and (1 shl 13) <> 0;
+    combination := combination and not (1 shl 13);
+    significand := (aValue and QWord($3FFFFFFFFFFFF)); // 50 bits
+    // Combination field not starting with "11"
+    if combination shr 11 <> %11 then begin
+      // The last 50 bits are the significand continuation field, consisting of five 10-bit declets. Each declet encodes three decimal digits using the DPD encoding.
+      // (5 declets * 3 digits + extra 1 digit = 16 digits)
+      exponent := ((combination shr 3) and $300) or (combination and $FF);
+      leading_digit := (combination shr 8) and 7;
+    end
+    else begin
+      exponent := ((combination shr 1) and $300) or (combination and $FF);
+      leading_digit := 8 or ((combination shr 8) and 1);
+    end;
+
+    p := -Integer(exponent)+398;
+    if p > 0 then begin
+      bh.Plac:=p;
+      bh.LDig:=p;
+    end;
+
+    // decode 5 declets
+    while significand<>0 do begin
+      declet := significand and $3FF; // 10 bits
+      a := (declet shr 1) and %110111;
+      b := a and %111;
+      c0 := (declet and 1);
+      c1 := (declet shr 4) and %111;
+      c2 := (declet shr 7) and %111;
+      // 1st digit
+      if b<=4 then                       // 1-2
+        d0:=declet and %1111
+      else if b<=5 then                  // 3
+        d0:=(c1 and %110) or c0
+      else if b mod a < 7 then           // 4-5
+        d0:=(c2 and %110) or c0
+      else                               // 6-8
+        d0:=%1000 or c0;
+      // 2nd digit
+      if (b and %101) xor %101 <> 0 then // 1,2,4
+        d1:=c1
+      else if a xor %010111 = 0 then     // 6
+        d1:=(c2 and %110) or (c1 and 1)
+      else                               // 5,7-8
+        d1:=%1000 or (c1 and 1);
+      // 3rd digit
+      if (b<=5) or (a=%100111) then      // 1-3, 7
+        d2:=c2
+      else
+        d2:=%1000 or (c2 and 1);
+
+      if (p < Low(bh.Singles)+2) or (p > High(bh.Singles)) then raise eBCDOverflowException.Create('in DPDec64ToBCD');
+
+      bh.Singles[p]:=d0;
+      Dec(p);
+      bh.Singles[p]:=d1;
+      Dec(p);
+      bh.Singles[p]:=d2;
+      Dec(p);
+
+      significand := significand shr 10;
+    end;
+    if leading_digit <> 0 then begin
+      bh.Singles[p]:=leading_digit;
+      Dec(p);
+    end;
+    bh.FDig := p+1;
+    pack_BCD ( bh, Result );
+  end;
+
+
   function CurrToBCD ( const Curr : currency;
                          var BCD : tBCD;
                              Precision : Integer = 32;
@@ -1941,6 +2036,69 @@ IMPLEMENTATION
     end;
   end;
 
+  { Convert BCD struct to IEEE 754 Densely packed decimal64 format }
+
+  function BCDToDPDec64 ( const BCD : tBCD ) : QWord;
+
+  var
+    bh : tBCD_helper;
+    i: integer;
+    combination, exponent, leading_digit: DWord;
+    declet: Word;
+    d0,d1,d2: Word;
+
+  begin
+    unpack_BCD ( BCD, bh );
+    // encode exactly 16 digits
+    if bh.Prec < 16 then begin
+      Dec(bh.FDig, 16-bh.Prec);
+      bh.Prec := 16;
+    end
+    else if (bh.Prec > 16) and (bh.Prec-bh.Plac <= 16) then begin
+      // truncate decimal places
+      bh.Plac := 16-(bh.Prec-bh.Plac);
+    end;
+    // exponent
+    if bh.FDig < -15 then
+      exponent := 398 - bh.FDig - 15
+    else
+      exponent := 398 - bh.Plac;
+    // sign bit
+    if bh.Neg then Result := 1 shl 13 else Result := 0;
+    // leading 1 digit
+    leading_digit := bh.Singles[bh.FDig];
+    if leading_digit < 8 then
+      combination := ((exponent shl 3) and %1100000000000) or (leading_digit shl 8)
+    else
+      combination := ((exponent shl 1) and %0011000000000) or ((leading_digit and %1) shl 8) or (%1100000000000);
+    Result := Result or combination or (exponent and %11111111);
+    // next 15 digits
+    i := bh.FDig;
+    while i < bh.FDig+15 do begin
+      Result := Result shl 10;
+
+      Inc(i);
+      d2:=bh.Singles[i];
+      Inc(i);
+      d1:=bh.Singles[i];
+      Inc(i);
+      d0:=bh.Singles[i];
+
+      case ((d2 and 8) shr 1) or ((d1 and 8) shr 2) or ((d0 and 8) shr 3) of
+        %000: declet := (d2 shl 7) or (d1 shl 4) or d0;
+        %001: declet := (d2 shl 7) or (d1 shl 4) or %1000;
+        %010: declet := (d2 shl 7) or ((d0 and %110) shl 4) or ((d0 and 1) shl 4) or %1010;
+        %011: declet := (d2 shl 7) or (d1 shl 4) or %1001110;
+        %100: declet := ((d0 and %110) shl 7) or ((d2 and 1) shl 7) or (d1 shl 4) or %1100;
+        %101: declet := ((d1 and %110) shl 7) or ((d2 and 1) shl 7) or ((d1 and 1) shl 4) or %0101110;
+        %110: declet := ((d0 and %110) shl 7) or ((d2 and 1) shl 7) or ((d1 and 1) shl 4) or %1110;
+        %111: declet := ((d2 and 1) shl 7) or ((d1 and 1) shl 4) or %1101110;
+      end;
+      declet := declet or (d0 and 1);
+      Result := Result or declet;
+    end;
+  end;
+
 { From DB.pas }
   function BCDToCurr ( const BCD : tBCD;
                          var Curr : currency ) : Boolean;