development/compilers/freepascal/compiler/crc.pas

   1 {
   2     $Id$
   3     Copyright (c) 2000 by Free Pascal Development Team
   4
   5     Routines to compute CRC values
   6
   7     This program is free software; you can redistribute it and/or modify
   8     it under the terms of the GNU General Public License as published by
   9     the Free Software Foundation; either version 2 of the License, or
  10     (at your option) any later version.
  11
  12     This program is distributed in the hope that it will be useful,
  13     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15     GNU General Public License for more details.
  16
  17     You should have received a copy of the GNU General Public License
  18     along with this program; if not, write to the Free Software
  19     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21  ****************************************************************************
  22 }
  23 Unit CRC;
  24
  25 Interface
  26 Function Crc32(Const HStr:String):longint;
  27 Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint;
  28 Function UpdCrc32(InitCrc:longint;b:byte):longint;
  29
  30
  31 Implementation
  32
  33 {*****************************************************************************
  34                                    Crc 32
  35 *****************************************************************************}
  36
  37 var
  38   Crc32Tbl : array[0..255] of longint;
  39
  40 procedure MakeCRC32Tbl;
  41 var
  42   crc : longint;
  43   i,n : byte;
  44 begin
  45   for i:=0 to 255 do
  46    begin
  47      crc:=i;
  48      for n:=1 to 8 do
  49       if odd(crc) then
  50        crc:=(crc shr 1) xor longint($edb88320)
  51       else
  52        crc:=crc shr 1;
  53      Crc32Tbl[i]:=crc;
  54    end;
  55 end;
  56
  57
  58 {$ifopt R+}
  59 {$define Range_check_on}
  60 {$endif opt R+}
  61
  62 {$R- needed here }
  63 {CRC 32}
  64 Function Crc32(Const HStr:String):longint;
  65 var
  66   i,InitCrc : longint;
  67 begin
  68   if Crc32Tbl[1]=0 then
  69    MakeCrc32Tbl;
  70   InitCrc:=longint($ffffffff);
  71   for i:=1 to Length(Hstr) do
  72    InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(Hstr[i])] xor (InitCrc shr 8);
  73   Crc32:=InitCrc;
  74 end;
  75
  76
  77
  78 Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint;
  79 var
  80   i : word;
  81   p : pchar;
  82 begin
  83   if Crc32Tbl[1]=0 then
  84    MakeCrc32Tbl;
  85   p:=@InBuf;
  86   for i:=1 to InLen do
  87    begin
  88      InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8);
  89      inc(longint(p));
  90    end;
  91   UpdateCrc32:=InitCrc;
  92 end;
  93
  94
  95
  96 Function UpdCrc32(InitCrc:longint;b:byte):longint;
  97 begin
  98   if Crc32Tbl[1]=0 then
  99    MakeCrc32Tbl;
 100   UpdCrc32:=Crc32Tbl[byte(InitCrc) xor b] xor (InitCrc shr 8);
 101 end;
 102
 103 {$ifdef Range_check_on}
 104 {$R+}
 105 {$undef Range_check_on}
 106 {$endif Range_check_on}
 107
 108 end.