development/compilers/freepascal/rtl/inc/int64.inc

   1 {
   2     $Id$
   3     This file is part of the Free Pascal run time library.
   4     Copyright (c) 1999-2000 by the Free Pascal development team
   5
   6     This file contains some helper routines for int64 and qword
   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 {$Q- no overflow checking }
  17 {$R- no range checking }
  18
  19     type
  20        tqwordrec = packed record
  21          low : dword;
  22          high : dword;
  23        end;
  24
  25     function count_leading_zeros(q : qword) : longint;
  26
  27       var
  28          r,i : longint;
  29
  30       begin
  31          r:=0;
  32          for i:=0 to 31 do
  33            begin
  34               if (tqwordrec(q).high and ($80000000 shr i))<>0 then
  35                 begin
  36                    count_leading_zeros:=r;
  37                    exit;
  38                 end;
  39               inc(r);
  40            end;
  41          for i:=0 to 31 do
  42            begin
  43               if (tqwordrec(q).low and ($80000000 shr i))<>0 then
  44                 begin
  45                    count_leading_zeros:=r;
  46                    exit;
  47                 end;
  48               inc(r);
  49            end;
  50          count_leading_zeros:=r;
  51       end;
  52
  53     function divqword(n,z : qword) : qword;[public,alias: 'FPC_DIV_QWORD'];
  54
  55       var
  56          shift,lzz,lzn : longint;
  57          { one : qword; }
  58
  59       begin
  60          divqword:=0;
  61          if n=0 then
  62            HandleErrorFrame(200,get_frame);
  63          lzz:=count_leading_zeros(z);
  64          lzn:=count_leading_zeros(n);
  65          { if the denominator contains less zeros }
  66          { then the numerator                     }
  67          { the d is greater than the n            }
  68          if lzn<lzz then
  69            exit;
  70          shift:=lzn-lzz;
  71          n:=n shl shift;
  72          repeat
  73            if z>=n then
  74              begin
  75                 z:=z-n;
  76                 divqword:=divqword+(qword(1) shl shift);
  77              end;
  78            dec(shift);
  79            n:=n shr 1;
  80          until shift<0;
  81       end;
  82
  83     function modqword(n,z : qword) : qword;[public,alias: 'FPC_MOD_QWORD'];
  84
  85       var
  86          shift,lzz,lzn : longint;
  87
  88       begin
  89          modqword:=0;
  90          if n=0 then
  91            HandleErrorFrame(200,get_frame);
  92          lzz:=count_leading_zeros(z);
  93          lzn:=count_leading_zeros(n);
  94          { if the denominator contains less zeros }
  95          { then the numerator                     }
  96          { the d is greater than the n            }
  97          if lzn<lzz then
  98            begin
  99               modqword:=z;
 100               exit;
 101            end;
 102          shift:=lzn-lzz;
 103          n:=n shl shift;
 104          repeat
 105            if z>=n then
 106              z:=z-n;
 107            dec(shift);
 108            n:=n shr 1;
 109          until shift<0;
 110          modqword:=z;
 111       end;
 112
 113     function divint64(n,z : int64) : int64;[public,alias: 'FPC_DIV_INT64'];
 114
 115       var
 116          sign : boolean;
 117          q1,q2 : qword;
 118          c : comp;
 119
 120       begin
 121          if n=0 then
 122            HandleErrorFrame(200,get_frame);
 123          { can the fpu do the work? }
 124          if fpuint64 then
 125            begin
 126               // the c:=comp(...) is necessary to shut up the compiler
 127               c:=comp(comp(z)/comp(n));
 128               divint64:=qword(c);
 129            end
 130          else
 131            begin
 132               sign:=false;
 133               if z<0 then
 134                 begin
 135                    sign:=not(sign);
 136                    q1:=qword(-z);
 137                 end
 138               else
 139                 q1:=z;
 140               if n<0 then
 141                 begin
 142                    sign:=not(sign);
 143                    q2:=qword(-n);
 144                 end
 145               else
 146                 q2:=n;
 147
 148               { the div is coded by the compiler as call to divqword }
 149               if sign then
 150                 divint64:=-(q1 div q2)
 151               else
 152                 divint64:=q1 div q2;
 153            end;
 154       end;
 155
 156     function modint64(n,z : int64) : int64;[public,alias: 'FPC_MOD_INT64'];
 157
 158       var
 159          signed : boolean;
 160          r,nq,zq : qword;
 161
 162       begin
 163          if n=0 then
 164            HandleErrorFrame(200,get_frame);
 165          if n<0 then
 166            begin
 167               nq:=-n;
 168               signed:=true;
 169            end
 170          else
 171            begin
 172               signed:=false;
 173               nq:=n;
 174            end;
 175          if z<0 then
 176            begin
 177               zq:=qword(-z);
 178               signed:=not(signed);
 179            end
 180          else
 181            zq:=z;
 182          r:=zq mod nq;
 183          if signed then
 184            modint64:=-int64(r)
 185          else
 186            modint64:=r;
 187       end;
 188
 189     { multiplies two qwords
 190       the longbool for checkoverflow avoids a misaligned stack
 191     }
 192     function mulqword(f1,f2 : qword;checkoverflow : longbool) : qword;[public,alias: 'FPC_MUL_QWORD'];
 193
 194       var
 195          _f1,bitpos : qword;
 196          l : longint;
 197
 198 {$ifdef i386}
 199          r : qword;
 200 {$endif i386}
 201
 202       begin
 203 {$ifdef i386}
 204          if not(checkoverflow) then
 205            begin
 206               asm
 207                  movl f1+4,%edx
 208                  movl f2+4,%ecx
 209                  orl %ecx,%edx
 210                  movl f2,%edx
 211                  movl f1,%eax
 212                  jnz .Lqwordmultwomul
 213                  mull %edx
 214                  jmp .Lqwordmulready
 215               .Lqwordmultwomul:
 216                  imul f1+4,%edx
 217                  imul %eax,%ecx
 218                  addl %edx,%ecx
 219                  mull f2
 220                  add %ecx,%edx
 221               .Lqwordmulready:
 222                  movl %eax,r
 223                  movl %edx,r+4
 224               end;
 225               mulqword:=r;
 226            end
 227          else
 228 {$endif i386}
 229            begin
 230               mulqword:=0;
 231               bitpos:=1;
 232
 233               // store f1 for overflow checking
 234               _f1:=f1;
 235
 236               for l:=0 to 63 do
 237                 begin
 238                    if (f2 and bitpos)<>0 then
 239                      mulqword:=mulqword+f1;
 240
 241                    f1:=f1 shl 1;
 242                    bitpos:=bitpos shl 1;
 243                 end;
 244
 245               { if one of the operands is greater than the result an }
 246               { overflow occurs                                      }
 247               if checkoverflow and (_f1 <> 0) and (f2 <>0) and
 248                  ((_f1>mulqword) or (f2>mulqword)) then
 249                 HandleErrorFrame(215,get_frame);
 250            end;
 251       end;
 252
 253     {    multiplies two int64 ....
 254        fpuint64 = false:
 255          ... using the the qword multiplication
 256        fpuint64 = true:
 257          ... using the comp multiplication
 258        the longbool for checkoverflow avoids a misaligned stack
 259      }
 260     function mulint64(f1,f2 : int64;checkoverflow : longbool) : int64;[public,alias: 'FPC_MUL_INT64'];
 261
 262       var
 263          sign : boolean;
 264          q1,q2,q3 : qword;
 265          c : comp;
 266
 267       begin
 268          { can the fpu do the work ? }
 269          if fpuint64 and not(checkoverflow) then
 270            begin
 271               // the c:=comp(...) is necessary to shut up the compiler
 272               c:=comp(comp(f1)*comp(f2));
 273               mulint64:=int64(c);
 274            end
 275          else
 276            begin
 277               sign:=false;
 278               if f1<0 then
 279                 begin
 280                    sign:=not(sign);
 281                    q1:=qword(-f1);
 282                 end
 283               else
 284                 q1:=f1;
 285               if f2<0 then
 286                 begin
 287                    sign:=not(sign);
 288                    q2:=qword(-f2);
 289                 end
 290               else
 291                 q2:=f2;
 292               { the q1*q2 is coded as call to mulqword }
 293               q3:=q1*q2;
 294
 295               if checkoverflow and (q1 <> 0) and (q2 <>0) and
 296               ((q1>q3) or (q2>q3) or
 297                 { the bit 63 can be only set if we have $80000000 00000000 }
 298                 { and sign is true                                         }
 299                 ((tqwordrec(q3).high and $80000000)<>0) and
 300                  ((q3<>(qword(1) shl 63)) or not(sign))
 301                 ) then
 302                 HandleErrorFrame(215,get_frame);
 303
 304               if sign then
 305                 mulint64:=-q3
 306               else
 307                 mulint64:=q3;
 308            end;
 309       end;
 310
 311     procedure qword_str(value : qword;var s : string);
 312
 313       var
 314          hs : string;
 315
 316       begin
 317          hs:='';
 318          repeat
 319            hs:=chr(longint(value mod 10)+48)+hs;
 320            value:=value div 10;
 321          until value=0;
 322          s:=hs;
 323       end;
 324
 325     procedure int64_str(value : int64;var s : string);
 326
 327       var
 328          hs : string;
 329          q : qword;
 330
 331       begin
 332          if value<0 then
 333            begin
 334               q:=qword(-value);
 335               qword_str(q,hs);
 336               s:='-'+hs;
 337            end
 338          else
 339            qword_str(qword(value),s);
 340       end;
 341
 342   procedure int_str_qword(v : qword;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_QWORD'];
 343
 344     begin
 345        qword_str(v,s);
 346         if length(s)<len then
 347           s:=space(len-length(s))+s;
 348     end;
 349
 350   procedure int_str_int64(v : int64;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_INT64'];
 351
 352     begin
 353        int64_str(v,s);
 354        if length(s)<len then
 355          s:=space(len-length(s))+s;
 356     end;
 357
 358   procedure int_str_qword(v : qword;len : longint;var s : ansistring);[public,alias:'FPC_ANSISTR_QWORD'];
 359
 360     var
 361        ss : shortstring;
 362
 363     begin
 364        int_str_qword(v,len,ss);
 365        s:=ss;
 366     end;
 367
 368   procedure int_str_int64(v : int64;len : longint;var s : ansistring);[public,alias:'FPC_ANSISTR_INT64'];
 369
 370     var
 371        ss : shortstring;
 372
 373     begin
 374        int_str_int64(v,len,ss);
 375        s:=ss;
 376     end;
 377
 378   Function ValInt64(Const S: ShortString; var Code: ValSInt): Int64; [public, alias:'FPC_VAL_INT64_SHORTSTR'];
 379    type
 380      QWordRec = packed record
 381        l1,l2: longint;
 382      end;
 383
 384     var
 385        u, temp, prev, maxint64, maxqword : qword;
 386        base : byte;
 387        negative : boolean;
 388
 389   begin
 390     ValInt64 := 0;
 391     Temp:=0;
 392     Code:=InitVal(s,negative,base);
 393     if Code>length(s) then
 394      exit;
 395     { high(int64) produces 0 in version 1.0 (JM) }
 396     with qwordrec(maxint64) do
 397       begin
 398         l1 := $ffffffff;
 399         l2 := $7fffffff;
 400       end;
 401     with qwordrec(maxqword) do
 402       begin
 403         l1 := $ffffffff;
 404         l2 := $ffffffff;
 405       end;
 406
 407     while Code<=Length(s) do
 408      begin
 409        case s[Code] of
 410          '0'..'9' : u:=Ord(S[Code])-Ord('0');
 411          'A'..'F' : u:=Ord(S[Code])-(Ord('A')-10);
 412          'a'..'f' : u:=Ord(S[Code])-(Ord('a')-10);
 413        else
 414         u:=16;
 415        end;
 416        Prev:=Temp;
 417        Temp:=Temp*Int64(base);
 418      If (u >= base) or
 419         ((base = 10) and
 420          (maxint64-temp+ord(negative) < u)) or
 421         ((base <> 10) and
 422          (qword(maxqword-temp) < u)) or
 423         (prev > maxqword div qword(base)) Then
 424        Begin
 425          ValInt64 := 0;
 426          Exit
 427        End;
 428        Temp:=Temp+u;
 429        inc(code);
 430      end;
 431     code:=0;
 432     ValInt64:=int64(Temp);
 433     If Negative Then
 434       ValInt64:=-ValInt64;
 435   end;
 436
 437
 438   Function ValQWord(Const S: ShortString; var Code: ValSInt):QWord;[public,alias:'FPC_VAL_QWORD_SHORTSTR'];
 439     type qwordrec = packed record
 440       l1,l2: longint;
 441     end;
 442     var
 443        u, prev, maxqword: QWord;
 444        base : byte;
 445        negative : boolean;
 446   begin
 447     ValQWord:=0;
 448     Code:=InitVal(s,negative,base);
 449     If Negative or (Code>length(s)) Then
 450       Exit;
 451     with qwordrec(maxqword) do
 452       begin
 453         l1 := $ffffffff;
 454         l2 := $ffffffff;
 455       end;
 456     while Code<=Length(s) do
 457      begin
 458        case s[Code] of
 459          '0'..'9' : u:=Ord(S[Code])-Ord('0');
 460          'A'..'F' : u:=Ord(S[Code])-(Ord('A')-10);
 461          'a'..'f' : u:=Ord(S[Code])-(Ord('a')-10);
 462        else
 463         u:=16;
 464        end;
 465        prev := ValQWord;
 466        If (u>=base) or
 467          ((QWord(maxqword-u) div QWord(base))<prev) then
 468          Begin
 469            ValQWord := 0;
 470            Exit
 471          End;
 472        ValQWord:=ValQWord*QWord(base)+u;
 473        inc(code);
 474      end;
 475     code := 0;
 476   end;
 477
 478 {
 479   $Log$
 480   Revision 1.1  2002/02/19 08:25:23  sasu
 481   Initial revision
 482
 483   Revision 1.1.2.6  2000/12/09 22:54:06  florian
 484     * helper name for qword-val fixed
 485
 486   Revision 1.1.2.5  2000/12/09 22:37:31  florian
 487     * fixed last commit, under go32v2 it worked
 488
 489   Revision 1.1.2.4  2000/12/09 20:49:33  florian
 490     * val for dword and qword didn't handle the max values
 491       correctly
 492     * val for qword works again
 493     + val with int64/qword and ansistring implemented
 494
 495   Revision 1.1.2.3  2000/11/17 16:56:42  jonas
 496     * fixed bug for val when processing -2147483648 and low(int64)
 497
 498   Revision 1.1.2.2  2000/07/28 12:19:21  jonas
 499     * fixed web bug1069
 500     * fixed similar (and other) problems in val() for int64 and qword
 501
 502   Revision 1.1.2.1  2000/07/16 08:55:26  jonas
 503     * fixed false overflow error if one of the operands of an int64/qword
 504       multiplication is 0
 505
 506   Revision 1.1  2000/07/13 06:30:47  michael
 507   + Initial import
 508
 509   Revision 1.20  2000/03/17 21:27:56  jonas
 510     * fixed declaration of val_int64 (removed destsize parameter)
 511     * fixed val_int64 and val_qword so they reject invalid input
 512       (u >= base)
 513     * when reading a number, invalid input is removed from the input
 514       buffer (+ it should be faster as well)
 515
 516   Revision 1.19  2000/02/09 22:19:24  florian
 517     + helper routine for <int64> mod <in64> added
 518
 519   Revision 1.18  2000/02/09 16:59:30  peter
 520     * truncated log
 521
 522   Revision 1.17  2000/01/27 15:43:02  florian
 523     * improved qword*qword code, if no overflow checking is done
 524
 525   Revision 1.16  2000/01/23 12:27:39  florian
 526     * int64/int64 and int64*int64 is now done by the fpu if possible
 527
 528   Revision 1.15  2000/01/23 12:22:37  florian
 529     * reading of 64 bit type implemented
 530
 531   Revision 1.14  2000/01/07 16:41:34  daniel
 532     * copyright 2000
 533 }