paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-21 09:42:00 +01:00
Code Issues Packages Projects Releases Wiki Activity

* range check error fixes from Peter

Browse Source
This commit is contained in:
Jonas Maebe 2001-05-09 14:11:10 +00:00
parent 05cfc07952
commit d5526ff45c
6 changed files with 72 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
compiler/crc.pas
View File

@ -26,9 +26,9 @@ Unit CRC;
Interface Interface
Function Crc32(Const HStr:String):longint; Function Crc32(Const HStr:String):cardinal;
Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint; Function UpdateCrc32(InitCrc:cardinal;var InBuf;InLen:integer):cardinal;
Function UpdCrc32(InitCrc:longint;b:byte):longint; Function UpdCrc32(InitCrc:cardinal;b:byte):cardinal;
Implementation Implementation
@ -38,19 +38,19 @@ Implementation
*****************************************************************************} *****************************************************************************}
var var
Crc32Tbl : array[0..255] of longint; Crc32Tbl : array[0..255] of cardinal;
procedure MakeCRC32Tbl; procedure MakeCRC32Tbl;
var var
crc : longint; crc : cardinal;
i,n : byte; i,n : integer;
begin begin
for i:=0 to 255 do for i:=0 to 255 do
begin begin
crc:=i; crc:=i;
for n:=1 to 8 do for n:=1 to 8 do
if odd(crc) then if (crc and 1)<>0 then
crc:=(crc shr 1) xor longint($edb88320) crc:=(crc shr 1) xor cardinal($edb88320)
else else
crc:=crc shr 1; crc:=crc shr 1;
Crc32Tbl[i]:=crc; Crc32Tbl[i]:=crc;
@ -58,19 +58,14 @@ begin
end; end;
{$ifopt R+} Function Crc32(Const HStr:String):cardinal;
{$define Range_check_on}
{$endif opt R+}
{$R- needed here }
{CRC 32}
Function Crc32(Const HStr:String):longint;
var var
i,InitCrc : longint; i : integer;
InitCrc : cardinal;
begin begin
if Crc32Tbl[1]=0 then if Crc32Tbl[1]=0 then
MakeCrc32Tbl; MakeCrc32Tbl;
InitCrc:=longint($ffffffff); InitCrc:=cardinal($ffffffff);
for i:=1 to Length(Hstr) do for i:=1 to Length(Hstr) do
InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(Hstr[i])] xor (InitCrc shr 8); InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(Hstr[i])] xor (InitCrc shr 8);
Crc32:=InitCrc; Crc32:=InitCrc;
@ -78,9 +73,9 @@ end;
Function UpdateCrc32(InitCrc:longint;var InBuf;InLen:Longint):longint; Function UpdateCrc32(InitCrc:cardinal;var InBuf;InLen:Integer):cardinal;
var var
i : word; i : integer;
p : pchar; p : pchar;
begin begin
if Crc32Tbl[1]=0 then if Crc32Tbl[1]=0 then
@ -89,29 +84,27 @@ begin
for i:=1 to InLen do for i:=1 to InLen do
begin begin
InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8); InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8);
inc(longint(p)); inc(p);
end; end;
UpdateCrc32:=InitCrc; UpdateCrc32:=InitCrc;
end; end;
Function UpdCrc32(InitCrc:longint;b:byte):longint; Function UpdCrc32(InitCrc:cardinal;b:byte):cardinal;
begin begin
if Crc32Tbl[1]=0 then if Crc32Tbl[1]=0 then
MakeCrc32Tbl; MakeCrc32Tbl;
UpdCrc32:=Crc32Tbl[byte(InitCrc) xor b] xor (InitCrc shr 8); UpdCrc32:=Crc32Tbl[byte(InitCrc) xor b] xor (InitCrc shr 8);
end; end;
{$ifdef Range_check_on}
{$R+}
{$undef Range_check_on}
{$endif Range_check_on}
end. end.
{ {
$Log$ $Log$
Revision 1.4 2000-09-24 15:06:14 peter Revision 1.5 2001-05-09 14:11:10 jonas
* range check error fixes from Peter
Revision 1.4 2000/09/24 15:06:14 peter
* use defines.inc * use defines.inc
Revision 1.3 2000/08/13 13:04:38 peter Revision 1.3 2000/08/13 13:04:38 peter

9
compiler/cutils.pas
View File

@ -45,7 +45,7 @@ interface
function lower(const s : string) : string; function lower(const s : string) : string;
function trimspace(const s:string):string; function trimspace(const s:string):string;
procedure uppervar(var s : string); procedure uppervar(var s : string);
function hexstr(val : longint;cnt : byte) : string; function hexstr(val : cardinal;cnt : byte) : string;
function tostru(i:cardinal) : string; function tostru(i:cardinal) : string;
function tostr(i : longint) : string; function tostr(i : longint) : string;
function int64tostr(i : int64) : string; function int64tostr(i : int64) : string;
@ -267,7 +267,7 @@ uses
end; end;
function hexstr(val : longint;cnt : byte) : string; function hexstr(val : cardinal;cnt : byte) : string;
const const
HexTbl : array[0..15] of char='0123456789ABCDEF'; HexTbl : array[0..15] of char='0123456789ABCDEF';
var var
@ -633,7 +633,10 @@ initialization
end. end.
{ {
$Log$ $Log$
Revision 1.5 2000-12-24 12:25:31 peter Revision 1.6 2001-05-09 14:11:10 jonas
* range check error fixes from Peter
Revision 1.5 2000/12/24 12:25:31 peter
+ cstreams unit + cstreams unit
* dynamicarray object to class * dynamicarray object to class

11
compiler/fmodule.pas
View File

@ -139,14 +139,14 @@ interface
unitid : longint; unitid : longint;
name : pstring; name : pstring;
checksum, checksum,
interface_checksum : longint; interface_checksum : cardinal;
loaded : boolean; loaded : boolean;
in_uses, in_uses,
in_interface, in_interface,
is_stab_written : boolean; is_stab_written : boolean;
u : tmodule; u : tmodule;
constructor create(_u : tmodule;intface:boolean); constructor create(_u : tmodule;intface:boolean);
constructor create_to_load(const n:string;c,intfc:longint;intface:boolean); constructor create_to_load(const n:string;c,intfc:cardinal;intface:boolean);
destructor destroy;override; destructor destroy;override;
end; end;
@ -319,7 +319,7 @@ uses
end; end;
constructor tused_unit.create_to_load(const n:string;c,intfc:longint;intface:boolean); constructor tused_unit.create_to_load(const n:string;c,intfc:cardinal;intface:boolean);
begin begin
u:=nil; u:=nil;
in_interface:=intface; in_interface:=intface;
@ -636,7 +636,10 @@ uses
end. end.
{ {
$Log$ $Log$
Revision 1.14 2001-05-06 14:49:16 peter Revision 1.15 2001-05-09 14:11:10 jonas
* range check error fixes from Peter
Revision 1.14 2001/05/06 14:49:16 peter
* ppu object to class rewrite * ppu object to class rewrite
* move ppu read and write stuff to fppu * move ppu read and write stuff to fppu

19
compiler/fppu.pas
View File

@ -191,8 +191,8 @@ uses
{ Show Debug info } { Show Debug info }
Message1(unit_u_ppu_time,filetimestring(ppufiletime)); Message1(unit_u_ppu_time,filetimestring(ppufiletime));
Message1(unit_u_ppu_flags,tostr(flags)); Message1(unit_u_ppu_flags,tostr(flags));
Message1(unit_u_ppu_crc,tostr(ppufile.header.checksum)); Message1(unit_u_ppu_crc,hexstr(ppufile.header.checksum,8));
Message1(unit_u_ppu_crc,tostr(ppufile.header.interface_checksum)+' (intfc)'); Message1(unit_u_ppu_crc,hexstr(ppufile.header.interface_checksum,8)+' (intfc)');
do_compile:=false; do_compile:=false;
openppu:=true; openppu:=true;
end; end;
@ -394,8 +394,8 @@ uses
ppufile.putstring(hp.name^); ppufile.putstring(hp.name^);
{ the checksum should not affect the crc of this unit ! (PFV) } { the checksum should not affect the crc of this unit ! (PFV) }
ppufile.do_crc:=false; ppufile.do_crc:=false;
ppufile.putlongint(hp.checksum); ppufile.putlongint(longint(hp.checksum));
ppufile.putlongint(hp.interface_checksum); ppufile.putlongint(longint(hp.interface_checksum));
ppufile.putbyte(byte(hp.in_interface)); ppufile.putbyte(byte(hp.in_interface));
ppufile.do_crc:=true; ppufile.do_crc:=true;
hp:=tused_unit(hp.next); hp:=tused_unit(hp.next);
@ -570,14 +570,14 @@ uses
var var
hs : string; hs : string;
intfchecksum, intfchecksum,
checksum : longint; checksum : cardinal;
in_interface : boolean; in_interface : boolean;
begin begin
while not ppufile.endofentry do while not ppufile.endofentry do
begin begin
hs:=ppufile.getstring; hs:=ppufile.getstring;
checksum:=ppufile.getlongint; checksum:=cardinal(ppufile.getlongint);
intfchecksum:=ppufile.getlongint; intfchecksum:=cardinal(ppufile.getlongint);
in_interface:=(ppufile.getbyte<>0); in_interface:=(ppufile.getbyte<>0);
used_units.concat(tused_unit.create_to_load(hs,checksum,intfchecksum,in_interface)); used_units.concat(tused_unit.create_to_load(hs,checksum,intfchecksum,in_interface));
end; end;
@ -1143,7 +1143,10 @@ uses
end. end.
{ {
$Log$ $Log$
Revision 1.3 2001-05-08 21:06:30 florian Revision 1.4 2001-05-09 14:11:10 jonas
* range check error fixes from Peter
Revision 1.3 2001/05/08 21:06:30 florian
* some more support for widechars commited especially * some more support for widechars commited especially
regarding type casting and constants regarding type casting and constants

11
compiler/pmodules.pas
View File

@ -668,7 +668,7 @@ implementation
{$ifdef GDB} {$ifdef GDB}
pu : tused_unit; pu : tused_unit;
{$endif GDB} {$endif GDB}
store_crc,store_interface_crc : longint; store_crc,store_interface_crc : cardinal;
s2 : ^string; {Saves stack space} s2 : ^string; {Saves stack space}
force_init_final : boolean; force_init_final : boolean;
@ -1031,12 +1031,12 @@ implementation
if not(cs_compilesystem in aktmoduleswitches) then if not(cs_compilesystem in aktmoduleswitches) then
if store_interface_crc<>current_module.interface_crc then if store_interface_crc<>current_module.interface_crc then
Comment(V_Warning,current_module.ppufilename^+' Interface CRC changed '+ Comment(V_Warning,current_module.ppufilename^+' Interface CRC changed '+
tostr(store_crc)+'<>'+tostr(current_module.interface_crc)); hexstr(store_crc,8)+'<>'+hexstr(current_module.interface_crc,8));
{$ifdef EXTDEBUG} {$ifdef EXTDEBUG}
if not(cs_compilesystem in aktmoduleswitches) then if not(cs_compilesystem in aktmoduleswitches) then
if (store_crc<>current_module.crc) and simplify_ppu then if (store_crc<>current_module.crc) and simplify_ppu then
Comment(V_Warning,current_module.ppufilename^+' implementation CRC changed '+ Comment(V_Warning,current_module.ppufilename^+' implementation CRC changed '+
tostr(store_crc)+'<>'+tostr(current_module.interface_crc)); hexstr(store_crc,8)+'<>'+hexstr(current_module.interface_crc,8));
{$endif EXTDEBUG} {$endif EXTDEBUG}
{ remove static symtable (=refsymtable) here to save some mem } { remove static symtable (=refsymtable) here to save some mem }
@ -1300,7 +1300,10 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.30 2001-05-06 14:49:17 peter Revision 1.31 2001-05-09 14:11:10 jonas
* range check error fixes from Peter
Revision 1.30 2001/05/06 14:49:17 peter
* ppu object to class rewrite * ppu object to class rewrite
* move ppu read and write stuff to fppu * move ppu read and write stuff to fppu

24
compiler/utils/ppudump.pp
View File

@ -153,6 +153,21 @@ begin
end; end;
function hexstr(val : cardinal;cnt : byte) : string;
const
HexTbl : array[0..15] of char='0123456789ABCDEF';
var
i : longint;
begin
hexstr[0]:=char(cnt);
for i:=cnt downto 1 do
begin
hexstr[i]:=hextbl[val and $f];
val:=val shr 4;
end;
end;
{**************************************************************************** {****************************************************************************
Read Routines Read Routines
****************************************************************************} ****************************************************************************}
@ -1349,8 +1364,8 @@ begin
WriteLn('Target operating system : ',Target2Str(target)); WriteLn('Target operating system : ',Target2Str(target));
Writeln('Unit flags : ',PPUFlags2Str(flags)); Writeln('Unit flags : ',PPUFlags2Str(flags));
Writeln('FileSize (w/o header) : ',size); Writeln('FileSize (w/o header) : ',size);
Writeln('Checksum : ',checksum); Writeln('Checksum : ',hexstr(checksum,8));
Writeln('Interface Checksum : ',interface_checksum); Writeln('Interface Checksum : ',hexstr(interface_checksum,8));
end; end;
end; end;
{read the general stuff} {read the general stuff}
@ -1528,7 +1543,10 @@ begin
end. end.
{ {
$Log$ $Log$
Revision 1.2 2001-05-06 14:49:19 peter Revision 1.3 2001-05-09 14:11:10 jonas
* range check error fixes from Peter
Revision 1.2 2001/05/06 14:49:19 peter
* ppu object to class rewrite * ppu object to class rewrite
* move ppu read and write stuff to fppu * move ppu read and write stuff to fppu