freepascal.compiler/rtl/inc/int64.inc

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by the Free Pascal development team

    This file contains some helper routines for int64 and qword

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
{$Q- no overflow checking }
{$R- no range checking }

    type
{$ifdef ENDIAN_LITTLE}
       tqwordrec = packed record
         low : dword;
         high : dword;
       end;
{$endif ENDIAN_LITTLE}
{$ifdef ENDIAN_BIG}
       tqwordrec = packed record
         high : dword;
         low : dword;
       end;
{$endif ENDIAN_BIG}


{$ifdef  FPC_INCLUDE_SOFTWARE_SHIFT_INT64}

{$ifndef FPC_SYSTEM_HAS_SHL_QWORD}
    function fpc_shl_qword(value,shift : qword) : qword; [public,alias: 'FPC_SHL_QWORD']; {$ifdef hascompilerproc} compilerproc; {$endif}
      begin
        shift:=shift and 63;
        if shift=0 then
          result:=value
        else if shift>31 then
          begin
            tqwordrec(result).low:=0;
            tqwordrec(result).high:=tqwordrec(value).low shl (shift-32);
          end
        else
          begin
            tqwordrec(result).low:=tqwordrec(value).low shl shift;
            tqwordrec(result).high:=(tqwordrec(value).high shl shift) or (tqwordrec(value).low shr (32-shift));
          end;
      end;
{$endif FPC_SYSTEM_HAS_SHL_QWORD}


{$ifndef FPC_SYSTEM_HAS_SHR_QWORD}
   function fpc_shr_qword(value,shift : qword) : qword; [public,alias: 'FPC_SHR_QWORD']; {$ifdef hascompilerproc} compilerproc; {$endif}
      begin
        shift:=shift and 63;
        if shift=0 then
          result:=value
        else if shift>31 then
          begin
            tqwordrec(result).high:=0;
            tqwordrec(result).low:=tqwordrec(value).high shr (shift-32);
          end
        else
          begin
            tqwordrec(result).high:=tqwordrec(value).high shr shift;
            tqwordrec(result).low:=(tqwordrec(value).low shr shift) or (tqwordrec(value).high shl (32-shift));
          end;
      end;
{$endif FPC_SYSTEM_HAS_SHR_QWORD}


{$ifndef FPC_SYSTEM_HAS_SHL_INT64}
    function fpc_shl_int64(value,shift : int64) : int64; [public,alias: 'FPC_SHL_INT64']; {$ifdef hascompilerproc} compilerproc; {$endif}
      begin
        shift:=shift and 63;
        if shift=0 then
          result:=value
        else if shift>31 then
          begin
            tqwordrec(result).low:=0;
            tqwordrec(result).high:=tqwordrec(value).low shl (shift-32);
          end
        else
          begin
            tqwordrec(result).low:=tqwordrec(value).low shl shift;
            tqwordrec(result).high:=(tqwordrec(value).high shl shift) or (tqwordrec(value).low shr (32-shift));
          end;
      end;
{$endif FPC_SYSTEM_HAS_SHL_INT64}


{$ifndef FPC_SYSTEM_HAS_SHR_INT64}
    function fpc_shr_int64(value,shift : int64) : int64; [public,alias: 'FPC_SHR_INT64']; {$ifdef hascompilerproc} compilerproc; {$endif}
      begin
        shift:=shift and 63;
        if shift=0 then
          result:=value
        else if shift>31 then
          begin
            tqwordrec(result).high:=0;
            tqwordrec(result).low:=tqwordrec(value).high shr (shift-32);
          end
        else
          begin
            tqwordrec(result).high:=tqwordrec(value).high shr shift;
            tqwordrec(result).low:=(tqwordrec(value).low shr shift) or (tqwordrec(value).high shl (32-shift));
          end;
      end;
{$endif FPC_SYSTEM_HAS_SHR_INT64}


{$endif FPC_INCLUDE_SOFTWARE_SHIFT_INT64}


    function count_leading_zeros(q : qword) : longint;

      var
         r,i : longint;

      begin
         r:=0;
         for i:=0 to 31 do
           begin
              if (tqwordrec(q).high and (dword($80000000) shr i))<>0 then
                begin
                   count_leading_zeros:=r;
                   exit;
                end;
              inc(r);
           end;
         for i:=0 to 31 do
           begin
              if (tqwordrec(q).low and (dword($80000000) shr i))<>0 then
                begin
                   count_leading_zeros:=r;
                   exit;
                end;
              inc(r);
           end;
         count_leading_zeros:=r;
      end;


{$ifndef FPC_SYSTEM_HAS_DIV_QWORD}
    function fpc_div_qword(n,z : qword) : qword;[public,alias: 'FPC_DIV_QWORD']; {$ifdef hascompilerproc} compilerproc; {$endif}

      var
         shift,lzz,lzn : longint;

      begin
         fpc_div_qword:=0;
         if n=0 then
           HandleErrorFrame(200,get_frame);
         lzz:=count_leading_zeros(z);
         lzn:=count_leading_zeros(n);
         { if the denominator contains less zeros }
         { then the numerator                     }
         { the d is greater than the n            }
         if lzn<lzz then
           exit;
         shift:=lzn-lzz;
         n:=n shl shift;
         repeat
           if z>=n then
             begin
                z:=z-n;
                fpc_div_qword:=fpc_div_qword+(qword(1) shl shift);
             end;
           dec(shift);
           n:=n shr 1;
         until shift<0;
      end;
{$endif FPC_SYSTEM_HAS_DIV_QWORD}


{$ifndef FPC_SYSTEM_HAS_MOD_QWORD}
    function fpc_mod_qword(n,z : qword) : qword;[public,alias: 'FPC_MOD_QWORD']; {$ifdef hascompilerproc} compilerproc; {$endif}

      var
         shift,lzz,lzn : longint;

      begin
         fpc_mod_qword:=0;
         if n=0 then
           HandleErrorFrame(200,get_frame);
         lzz:=count_leading_zeros(z);
         lzn:=count_leading_zeros(n);
         { if the denominator contains less zeros }
         { then the numerator                     }
         { the d is greater than the n            }
         if lzn<lzz then
           begin
              fpc_mod_qword:=z;
              exit;
           end;
         shift:=lzn-lzz;
         n:=n shl shift;
         repeat
           if z>=n then
             z:=z-n;
           dec(shift);
           n:=n shr 1;
         until shift<0;
         fpc_mod_qword:=z;
      end;
{$endif FPC_SYSTEM_HAS_MOD_QWORD}


{$ifndef FPC_SYSTEM_HAS_DIV_INT64}
    function fpc_div_int64(n,z : int64) : int64;[public,alias: 'FPC_DIV_INT64']; {$ifdef hascompilerproc} compilerproc; {$endif}

      var
         sign : boolean;
         q1,q2 : qword;

      begin
         if n=0 then
           HandleErrorFrame(200,get_frame);
         { can the fpu do the work? }
           begin
              sign:=false;
              if z<0 then
                begin
                   sign:=not(sign);
                   q1:=qword(-z);
                end
              else
                q1:=z;
              if n<0 then
                begin
                   sign:=not(sign);
                   q2:=qword(-n);
                end
              else
                q2:=n;

              { the div is coded by the compiler as call to divqword }
              if sign then
                fpc_div_int64:=-(q1 div q2)
              else
                fpc_div_int64:=q1 div q2;
           end;
      end;
{$endif FPC_SYSTEM_HAS_DIV_INT64}


{$ifndef FPC_SYSTEM_HAS_MOD_INT64}
    function fpc_mod_int64(n,z : int64) : int64;[public,alias: 'FPC_MOD_INT64']; {$ifdef hascompilerproc} compilerproc; {$endif}

      var
         signed : boolean;
         r,nq,zq : qword;

      begin
         if n=0 then
           HandleErrorFrame(200,get_frame);
         if n<0 then
           nq:=-n
         else
           nq:=n;
         if z<0 then
           begin
             signed:=true;
             zq:=qword(-z)
           end
         else
           begin
             signed:=false;
             zq:=z;
           end;
         r:=zq mod nq;
         if signed then
           fpc_mod_int64:=-int64(r)
         else
           fpc_mod_int64:=r;
      end;
{$endif FPC_SYSTEM_HAS_MOD_INT64}


{$ifndef FPC_SYSTEM_HAS_MUL_QWORD}
    { multiplies two qwords
      the longbool for checkoverflow avoids a misaligned stack
    }
    function fpc_mul_qword(f1,f2 : qword;checkoverflow : longbool) : qword;[public,alias: 'FPC_MUL_QWORD']; {$ifdef hascompilerproc} compilerproc; {$endif}

      var
         _f1,bitpos : qword;
         l : longint;
         f1overflowed : boolean;
      begin
        fpc_mul_qword:=0;
        bitpos:=1;
	f1overflowed:=false;

        for l:=0 to 63 do
          begin
            if (f2 and bitpos)<>0 then
              begin
                _f1:=fpc_mul_qword;
                fpc_mul_qword:=fpc_mul_qword+f1;

                { if one of the operands is greater than the result an
                  overflow occurs                                      }
                if checkoverflow and (f1overflowed or ((_f1<>0) and (f1<>0) and
                  ((_f1>fpc_mul_qword) or (f1>fpc_mul_qword)))) then
                  HandleErrorFrame(215,get_frame);
              end;
{$ifndef VER1_0}
            { when bootstrapping, we forget about overflow checking for qword :) }
            f1overflowed:=f1overflowed or ((f1 and (1 shl 63))<>0);
{$endif VER1_0}
            f1:=f1 shl 1;
            bitpos:=bitpos shl 1;
          end;
      end;
{$endif FPC_SYSTEM_HAS_MUL_QWORD}


{$ifndef FPC_SYSTEM_HAS_MUL_INT64}
    function fpc_mul_int64(f1,f2 : int64;checkoverflow : longbool) : int64;[public,alias: 'FPC_MUL_INT64']; {$ifdef hascompilerproc} compilerproc; {$endif}

      var
         sign : boolean;
         q1,q2,q3 : qword;

      begin
           begin
              sign:=false;
              if f1<0 then
                begin
                   sign:=not(sign);
                   q1:=qword(-f1);
                end
              else
                q1:=f1;
              if f2<0 then
                begin
                   sign:=not(sign);
                   q2:=qword(-f2);
                end
              else
                q2:=f2;
              { the q1*q2 is coded as call to mulqword }
              q3:=q1*q2;

              if checkoverflow and (q1 <> 0) and (q2 <>0) and
              ((q1>q3) or (q2>q3) or
                { the bit 63 can be only set if we have $80000000 00000000 }
                { and sign is true                                         }
                ((tqwordrec(q3).high and dword($80000000))<>0) and
                 ((q3<>(qword(1) shl 63)) or not(sign))
                ) then
                HandleErrorFrame(215,get_frame);

              if sign then
                fpc_mul_int64:=-q3
              else
                fpc_mul_int64:=q3;
           end;
      end;
{$endif FPC_SYSTEM_HAS_MUL_INT64}

{
  $Log$
  Revision 1.28  2004-09-26 07:37:49  florian
    * fixed overflow checking for qword

  Revision 1.27  2004/09/26 07:15:34  florian
    * tried to fix overflow checking in qword multiplication

  Revision 1.26  2004/05/23 14:09:43  peter
    * shr/shl use and 63 for the shift value

  Revision 1.25  2004/04/29 18:59:43  peter
    * str() helpers now also use valint/valuint
    * int64/qword helpers disabled for cpu64

  Revision 1.24  2004/04/24 17:14:09  florian
    * prt0.as exit code handling fixed
    * int64 mod int64 for negative numbers fixed

  Revision 1.23  2004/01/23 15:14:04  florian
    + implemented software shl/shr for 64 bit ints

  Revision 1.22  2003/09/14 11:34:13  peter
    * moved int64 asm code to int64p.inc
    * save ebx,esi

  Revision 1.21  2003/09/03 14:09:37  florian
    * arm fixes to the common rtl code
    * some generic math code fixed
    * ...

  Revision 1.20  2003/05/12 11:17:55  florian
    * fixed my commit, strange, it didn't give any conflicts with Jonas patch

  Revision 1.19  2003/05/12 11:16:21  florian
    * qword division fixed (MSB/LSB problem)

  Revision 1.18  2003/05/12 07:19:04  jonas
    * fixed for big endian systems (since Florian doesn't seem to want to
      commit this fix :)

  Revision 1.17  2002/09/07 21:21:42  carl
    - remove FPUInt64 variable

  Revision 1.16  2002/09/07 15:07:45  peter
    * old logs removed and tabs fixed

  Revision 1.15  2002/09/01 14:44:01  peter
    * renamed conditional to insert optimized mod_qword for i386. The
      code is broken

  Revision 1.14  2002/07/01 16:29:05  peter
    * sLineBreak changed to normal constant like Kylix

}