paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 20:29:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Fix block logic error, causing failure of tw12830.pp

Browse Source
This commit is contained in:
Michaël Van Canneyt 2023-07-12 12:10:09 +02:00
parent e4356a0d38
commit 87d084dd21
1 changed files with 59 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
packages/paszlib/src/infblock.pas
View File

@ -171,6 +171,9 @@ function inflate_blocks (var s : inflate_blocks_state;
var z : z_stream; var z : z_stream;
r : integer) : integer; { initial return code } r : integer) : integer; { initial return code }
Type
tblockaction = (baFallThrough,baContinue,baExit);
var var
t : cardinal; { temporary storage } t : cardinal; { temporary storage }
b : cardinal; { bit buffer } b : cardinal; { bit buffer }
@ -189,7 +192,7 @@ var
var var
cs : pInflate_codes_state; cs : pInflate_codes_state;
procedure do_btree; function do_btree : TBlockAction;
begin begin
while (s.sub.trees.index < 4 + (s.sub.trees.table shr 10)) do while (s.sub.trees.index < 4 + (s.sub.trees.table shr 10)) do
@ -210,7 +213,7 @@ var
z.next_in := p; z.next_in := p;
s.write := q; s.write := q;
inflate_blocks := inflate_flush(s,z,r); inflate_blocks := inflate_flush(s,z,r);
exit; exit(baExit);
end; end;
dec(n); dec(n);
b := b or (cardinal(p^) shl k); b := b or (cardinal(p^) shl k);
@ -247,7 +250,7 @@ var
z.next_in := p; z.next_in := p;
s.write := q; s.write := q;
inflate_blocks := inflate_flush(s,z,r); inflate_blocks := inflate_flush(s,z,r);
exit; exit(baExit);
end; end;
s.sub.trees.index := 0; s.sub.trees.index := 0;
{$IFDEF ZLIB_DEBUG} {$IFDEF ZLIB_DEBUG}
@ -255,9 +258,10 @@ var
{$ENDIF} {$ENDIF}
s.mode := DTREE; s.mode := DTREE;
{ fall through again } { fall through again }
do_btree:=baFallThrough;
end; end;
procedure do_dtree; function do_dtree : TBlockaction;
begin begin
while TRUE do while TRUE do
@ -283,7 +287,7 @@ var
z.next_in := p; z.next_in := p;
s.write := q; s.write := q;
inflate_blocks := inflate_flush(s,z,r); inflate_blocks := inflate_flush(s,z,r);
exit; exit(baExit);
end; end;
dec(n); dec(n);
b := b or (cardinal(p^) shl k); b := b or (cardinal(p^) shl k);
@ -333,7 +337,7 @@ var
z.next_in := p; z.next_in := p;
s.write := q; s.write := q;
inflate_blocks := inflate_flush(s,z,r); inflate_blocks := inflate_flush(s,z,r);
exit; exit(baExit);
end; end;
dec(n); dec(n);
b := b or (cardinal(p^) shl k); b := b or (cardinal(p^) shl k);
@ -368,7 +372,7 @@ var
z.next_in := p; z.next_in := p;
s.write := q; s.write := q;
inflate_blocks := inflate_flush(s,z,r); inflate_blocks := inflate_flush(s,z,r);
exit; exit(baExit);
end; end;
if c = 16 then if c = 16 then
c := s.sub.trees.blens^[i - 1] c := s.sub.trees.blens^[i - 1]
@ -405,7 +409,7 @@ var
z.next_in := p; z.next_in := p;
s.write := q; s.write := q;
inflate_blocks := inflate_flush(s,z,r); inflate_blocks := inflate_flush(s,z,r);
exit; exit(baExit);
end; end;
{$IFDEF ZLIB_DEBUG} {$IFDEF ZLIB_DEBUG}
Tracev('inflate: trees ok'); Tracev('inflate: trees ok');
@ -423,14 +427,16 @@ var
z.next_in := p; z.next_in := p;
s.write := q; s.write := q;
inflate_blocks := inflate_flush(s,z,r); inflate_blocks := inflate_flush(s,z,r);
exit; exit(baExit);
end; end;
s.sub.decode.codes := cs; s.sub.decode.codes := cs;
end; end;
s.mode := CODES; s.mode := CODES;
do_dtree:=baFallThrough;
end; end;
function do_codes: boolean;
function do_codes: tblockaction;
begin begin
{ update pointers } { update pointers }
@ -445,7 +451,7 @@ var
if (r <> Z_STREAM_END) then if (r <> Z_STREAM_END) then
begin begin
inflate_blocks := inflate_flush(s, z, r); inflate_blocks := inflate_flush(s, z, r);
exit; exit(baExit);
end; end;
r := Z_OK; r := Z_OK;
inflate_codes_free(s.sub.decode.codes, z); inflate_codes_free(s.sub.decode.codes, z);
@ -471,7 +477,7 @@ var
if (not s.last) then if (not s.last) then
begin begin
s.mode := ZTYPE; s.mode := ZTYPE;
exit(false); { break for switch statement in C-code } exit(baContinue); { break for switch statement in C-code }
end; end;
{$ifndef patch112} {$ifndef patch112}
if (k > 7) then { return unused byte, if any } if (k > 7) then { return unused byte, if any }
@ -485,10 +491,10 @@ var
end; end;
{$endif} {$endif}
s.mode := DRY; s.mode := DRY;
do_codes:=true; do_codes:=baFallThrough;
end; end;
procedure do_dry; function do_dry : tblockaction;
begin begin
{FLUSH} {FLUSH}
@ -513,9 +519,10 @@ var
z.next_in := p; z.next_in := p;
s.write := q; s.write := q;
inflate_blocks := inflate_flush(s,z,r); inflate_blocks := inflate_flush(s,z,r);
exit; exit(baExit);
end; end;
s.mode := BLKDONE; s.mode := BLKDONE;
do_dry:=baFallThrough;
end; end;
procedure do_blkdone; procedure do_blkdone;
@ -880,44 +887,62 @@ begin
s.mode := BTREE; s.mode := BTREE;
{ fall trough case is handled by the while } { fall trough case is handled by the while }
{ try GOTO for speed - Nomssi } { try GOTO for speed - Nomssi }
do_btree; if do_btree=baExit then
do_dtree; Exit;
if not do_codes then if do_dtree=baExit then
continue; Exit;
do_dry; Case do_codes of
baContinue : continue;
baExit : Exit;
end;
if do_dry=baExit then
exit;
do_blkdone; do_blkdone;
exit; exit;
end; end;
BTREE: BTREE:
begin begin
do_btree; if do_btree=baExit then
do_dtree; Exit;
if not do_codes then if do_dtree=baExit then
continue; Exit;
do_dry; Case do_codes of
baContinue : continue;
baExit : Exit;
end;
if do_dry=baExit then
exit;
do_blkdone; do_blkdone;
exit; exit;
end; end;
DTREE: DTREE:
begin begin
do_dtree; if do_dtree=baExit then
if not do_codes then Exit;
continue; Case do_codes of
do_dry; baContinue : continue;
baExit : Exit;
end;
if do_dry=baExit then
exit;
do_blkdone; do_blkdone;
exit; exit;
end; end;
CODES: CODES:
begin begin
if not do_codes then Case do_codes of
continue; baContinue : continue;
do_dry; baExit : Exit;
end;
if do_dry=baExit then
exit;
do_blkdone; do_blkdone;
exit; exit;
end; end;
DRY: DRY:
begin begin
do_dry; if do_dry=baExit then
exit;
do_blkdone; do_blkdone;
exit; exit;
end; end;