mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-09 00:08:12 +02:00
* fixed setting bitpacked record fields straddling their natural boundaries
to 0 or field_type(-1) (bug noted by Russell Davies on fpc-devel + his
test programs)
* fixed bit offset calculations for nested bitpacked record regvars
git-svn-id: trunk@11242 -
This commit is contained in:
Jonas Maebe
parent
9c77c7743d
commit
a60a957420
2
.gitattributes
vendored
2
.gitattributes
vendored
@ -7631,6 +7631,8 @@ tests/test/tprec19.pp svneol=native#text/plain
|
||||
tests/test/tprec2.pp svneol=native#text/plain
|
||||
tests/test/tprec20.pp svneol=native#text/plain
|
||||
tests/test/tprec21.pp svneol=native#text/plain
|
||||
tests/test/tprec22.pp svneol=native#text/plain
|
||||
tests/test/tprec23.pp svneol=native#text/plain
|
||||
tests/test/tprec3.pp svneol=native#text/plain
|
||||
tests/test/tprec4.pp svneol=native#text/plain
|
||||
tests/test/tprec5.pp svneol=native#text/plain
|
||||
|
||||
@ -1575,7 +1575,13 @@ implementation
|
||||
{ ... to startbit }
|
||||
tosreg.startbit := sref.startbit;
|
||||
end;
|
||||
a_load_subsetreg_subsetreg(list,subsetsize,subsetsize,fromsreg,tosreg);
|
||||
case slopt of
|
||||
SL_SETZERO,
|
||||
SL_SETMAX:
|
||||
a_load_regconst_subsetreg_intern(list,fromsize,subsetsize,fromreg,tosreg,slopt);
|
||||
else
|
||||
a_load_subsetreg_subsetreg(list,subsetsize,subsetsize,fromsreg,tosreg);
|
||||
end;
|
||||
valuereg := makeregsize(list,valuereg,loadsize);
|
||||
a_load_reg_ref(list,loadsize,loadsize,valuereg,sref.ref);
|
||||
|
||||
@ -1601,7 +1607,13 @@ implementation
|
||||
fromsreg.bitlen := sref.bitlen-fromsreg.bitlen;
|
||||
tosreg.bitlen := fromsreg.bitlen;
|
||||
|
||||
a_load_subsetreg_subsetreg(list,fromsize,subsetsize,fromsreg,tosreg);
|
||||
case slopt of
|
||||
SL_SETZERO,
|
||||
SL_SETMAX:
|
||||
a_load_regconst_subsetreg_intern(list,fromsize,subsetsize,fromreg,tosreg,slopt);
|
||||
else
|
||||
a_load_subsetreg_subsetreg(list,subsetsize,subsetsize,fromsreg,tosreg);
|
||||
end;
|
||||
extra_value_reg := makeregsize(list,extra_value_reg,loadsize);
|
||||
a_load_reg_ref(list,loadsize,loadsize,extra_value_reg,tmpref);
|
||||
exit;
|
||||
|
||||
@ -351,11 +351,22 @@ implementation
|
||||
LOC_CSUBSETREG:
|
||||
begin
|
||||
location.size:=def_cgsize(resultdef);
|
||||
if (target_info.endian = ENDIAN_BIG) then
|
||||
inc(location.sreg.startbit, (left.resultdef.size - tcgsize2size[location.size] - vs.fieldoffset) * 8)
|
||||
if not is_packed_record_or_object(left.resultdef) then
|
||||
begin
|
||||
if (target_info.endian = ENDIAN_BIG) then
|
||||
inc(location.sreg.startbit, (left.resultdef.size - tcgsize2size[location.size] - vs.fieldoffset) * 8)
|
||||
else
|
||||
inc(location.sreg.startbit, vs.fieldoffset * 8);
|
||||
location.sreg.bitlen := tcgsize2size[location.size] * 8;
|
||||
end
|
||||
else
|
||||
inc(location.sreg.startbit, vs.fieldoffset * 8);
|
||||
location.sreg.bitlen := tcgsize2size[location.size] * 8;
|
||||
begin
|
||||
location.sreg.bitlen := resultdef.packedbitsize;
|
||||
if (target_info.endian = ENDIAN_BIG) then
|
||||
inc(location.sreg.startbit, left.location.sreg.bitlen - location.sreg.bitlen - vs.fieldoffset)
|
||||
else
|
||||
inc(location.sreg.startbit, vs.fieldoffset);
|
||||
end;
|
||||
end;
|
||||
else
|
||||
internalerror(2006031901);
|
||||
|
||||
162
tests/test/tprec22.pp
Normal file
162
tests/test/tprec22.pp
Normal file
@ -0,0 +1,162 @@
|
||||
// http://lists.freepascal.org/lists/fpc-devel/2008-June/013919.html
|
||||
|
||||
// I was interested to see if bit packing works when a record member spans
|
||||
// byte boundaries, and in general it appears to work. However on my system
|
||||
// I discovered a bug that this program illustrates.
|
||||
//
|
||||
// This program demonstrates a bug using a bitpacked record where a member
|
||||
// crosses a byte boundary.
|
||||
// The record structure is (on little endian systems -- Jonas):
|
||||
// Member: | bit15_9 | bit8_1 | bit0 |
|
||||
// Bits: | 15 .. 9 | 8 .. 1 | 0 |
|
||||
// Value: | 0..127 | 0..255 | 0..1 |
|
||||
//
|
||||
// The structure is mapped to a word via a variant record for convenience.
|
||||
//
|
||||
// The limited amount of testing done indicates that the record member bit8_1
|
||||
// only causes a problem with a value of $FF, but the interesting thing is
|
||||
// that the result varies depending on other (unrelated) program structure.
|
||||
// For example the expected word result with bit 0 = 1, bits 1..9 = $FF and
|
||||
// the rest 0, should be $01FF but I have seen the correct value as well as
|
||||
// results of $0001, $0003, $0121, $012. Adding code before the tests seems
|
||||
// to change the result, possibly/ indicating that some variable or register
|
||||
// used in the bitpacking routine is not being cleared/initialized.
|
||||
//
|
||||
// Different compiler modes, optimisations, range checking were tried, but
|
||||
// the results were the same.
|
||||
//
|
||||
// Note that using a variant record to show the value is only a convenience
|
||||
// here and the error can be seen without a variant record by examining
|
||||
// the struct directly, or by overlaying the word using the absolute keyword.
|
||||
//
|
||||
// Tested on Intel Core 2 Duo running Windows XP Pro SP2, Compiler version
|
||||
// 2.2.0 [2007/09/09] and 2.3.1 [2008/02/03]
|
||||
|
||||
|
||||
|
||||
uses SysUtils;
|
||||
|
||||
|
||||
type
|
||||
bit = 0..1;
|
||||
t7bit = 0..127;
|
||||
|
||||
// A record to test behaviour over byte boundaries.
|
||||
BitStruct = bitpacked record
|
||||
bit0 : bit;
|
||||
bit8_1 : byte; // This set to $FF causes problems...
|
||||
bit15_9 : t7bit;
|
||||
end;
|
||||
|
||||
// Map the record to a word for convenience - but overlaying
|
||||
// a word using absolute instead a variant record produces
|
||||
// the same result.
|
||||
|
||||
MappedStruct = packed record
|
||||
case boolean of
|
||||
false : (AsWord : word);
|
||||
true : (AsBits : BitStruct);
|
||||
end;
|
||||
|
||||
|
||||
procedure TestBits;
|
||||
var
|
||||
TestLocal : MappedStruct;
|
||||
begin
|
||||
TestLocal.AsBits.bit0 := 1;
|
||||
TestLocal.AsBits.bit8_1 := $FF;
|
||||
TestLocal.AsBits.bit15_9 := $0;
|
||||
if (TestLocal.AsBits.bit0<>1) or
|
||||
(TestLocal.AsBits.bit8_1<>$ff) or
|
||||
(TestLocal.AsBits.bit15_9<>0) then
|
||||
halt(1);
|
||||
// writeln(' Expected : $01FF, Got : $',IntToHex(TestLocal.AsWord,4),' (I get $0121 V2.2.0, $0109 V2.3.1)');
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
TestGlobal : MappedStruct;
|
||||
begin
|
||||
//Do test in main routine - on my system results in $0001.
|
||||
// Also interesting - using 'with TestGlobal, AsBits do begin ...' instead of
|
||||
// fully qualified names returns different values in some cases.
|
||||
|
||||
Writeln('Testing in main: | $00 | $FF | 1 |');
|
||||
TestGlobal.AsBits.bit0 := 1;
|
||||
TestGlobal.AsBits.bit8_1 := $FF;
|
||||
TestGlobal.AsBits.bit15_9 := $0;
|
||||
if (TestGlobal.AsBits.bit0<>1) or
|
||||
(TestGlobal.AsBits.bit8_1<>$ff) or
|
||||
(TestGlobal.AsBits.bit15_9<>0) then
|
||||
halt(2);
|
||||
// writeln(' Expected : $01FF, Got : $',IntToHex(TestGlobal.AsWord,4), ' (I get $0001 V2.2.0, $01F9 V2.3.1)');
|
||||
|
||||
// Test it in a procedure - results in $0121 on V2.2.0
|
||||
writeln;
|
||||
Writeln('Testing in procedure: | $01 | $FF | 1 |');
|
||||
TestBits;
|
||||
|
||||
// Test this in main
|
||||
Writeln;
|
||||
Writeln('Back in main: | $3F | $FF | 1 |');
|
||||
TestGlobal.AsBits.bit0 := 1;
|
||||
TestGlobal.AsBits.bit8_1 := $FF;
|
||||
TestGlobal.AsBits.bit15_9 := $3F;
|
||||
if (TestGlobal.AsBits.bit0<>1) or
|
||||
(TestGlobal.AsBits.bit8_1<>$ff) or
|
||||
(TestGlobal.AsBits.bit15_9<>$3f) then
|
||||
halt(3);
|
||||
// writeln(' Expected : $7FFF, Got : $',IntToHex(TestGlobal.AsWord,4),' ($7E01 V2.2.0, $7FF9 V2.3.1)');
|
||||
|
||||
// and again in main.
|
||||
Writeln;
|
||||
Writeln('In main, | $7F | $FF | 1 |');
|
||||
TestGlobal.AsBits.bit0 := 1;
|
||||
TestGlobal.AsBits.bit8_1 := $FF;
|
||||
TestGlobal.AsBits.bit15_9 := $7F;
|
||||
if (TestGlobal.AsBits.bit0<>1) or
|
||||
(TestGlobal.AsBits.bit8_1<>$ff) or
|
||||
(TestGlobal.AsBits.bit15_9<>$7f) then
|
||||
halt(4);
|
||||
// writeln(' Expected : $FFFF, Got : $',IntToHex(TestGlobal.AsWord,4), ' ($FE01 V.2.2.0, $FFF9 V2.3.1)');
|
||||
|
||||
|
||||
// Now set bits 8..1 to $FE
|
||||
Writeln;
|
||||
Writeln('Above tests, but with bits 8..1 set to $FE - all work on my system');
|
||||
|
||||
Writeln(' | $00 | $FE | 1 |');
|
||||
TestGlobal.AsBits.bit0 := 1;
|
||||
TestGlobal.AsBits.bit8_1 := $FE;
|
||||
TestGlobal.AsBits.bit15_9 := $0;
|
||||
if (TestGlobal.AsBits.bit0<>1) or
|
||||
(TestGlobal.AsBits.bit8_1<>$fe) or
|
||||
(TestGlobal.AsBits.bit15_9<>0) then
|
||||
halt(5);
|
||||
// writeln(' Expected : $01FD, Got : $',IntToHex(TestGlobal.AsWord,4));
|
||||
|
||||
Writeln;
|
||||
Writeln(' | $3F | $FE | 1 |');
|
||||
TestGlobal.AsBits.bit0 := 1;
|
||||
TestGlobal.AsBits.bit8_1 := $FE;
|
||||
TestGlobal.AsBits.bit15_9 := $3F;
|
||||
if (TestGlobal.AsBits.bit0<>1) or
|
||||
(TestGlobal.AsBits.bit8_1<>$fe) or
|
||||
(TestGlobal.AsBits.bit15_9<>$3f) then
|
||||
halt(6);
|
||||
// writeln(' Expected : $7FFD, Got : $',IntToHex(TestGlobal.AsWord,4));
|
||||
|
||||
// and again in main.
|
||||
Writeln;
|
||||
Writeln(' | $7F | $FE | 1 |');
|
||||
TestGlobal.AsBits.bit0 := 1;
|
||||
TestGlobal.AsBits.bit8_1 := $FE;
|
||||
TestGlobal.AsBits.bit15_9 := $7F;
|
||||
if (TestGlobal.AsBits.bit0<>1) or
|
||||
(TestGlobal.AsBits.bit8_1<>$fe) or
|
||||
(TestGlobal.AsBits.bit15_9<>$7f) then
|
||||
halt(7);
|
||||
// writeln(' Expected : $FFFD, Got : $',IntToHex(TestGlobal.AsWord,4));
|
||||
|
||||
end.
|
||||
|
||||
224
tests/test/tprec23.pp
Normal file
224
tests/test/tprec23.pp
Normal file
@ -0,0 +1,224 @@
|
||||
// http://lists.freepascal.org/lists/fpc-devel/2008-June/013919.html
|
||||
|
||||
uses SysUtils;
|
||||
{$ASSERTIONS ON}
|
||||
type
|
||||
bit = 0..1;
|
||||
t6bit = 0..63;
|
||||
|
||||
ByteBoundary = bitpacked record
|
||||
bit0 : bit;
|
||||
bit1_8 : byte;
|
||||
bit9_15 : t6bit;
|
||||
end;
|
||||
|
||||
TestByteBoundary = record
|
||||
case boolean of
|
||||
false : (AsWord : word);
|
||||
true : (AsBits : ByteBoundary);
|
||||
end;
|
||||
|
||||
|
||||
procedure TestBits(b0 : bit; b1_8 : byte; b9_15 : t6bit);
|
||||
var
|
||||
Test : TestByteBoundary;
|
||||
w : word;
|
||||
begin
|
||||
{$ifdef fpc_little_endian}
|
||||
w := b0 + b1_8 shl 1 + b9_15 shl 9;
|
||||
{$else}
|
||||
w := b0 shl (16-1) + b1_8 shl (15-8) + b9_15 shl 1;
|
||||
{$endif}
|
||||
with Test, asBits do begin
|
||||
bit0 := b0;
|
||||
bit1_8 := b1_8;
|
||||
bit9_15 := b9_15;
|
||||
{$ifdef fpc_little_endian}
|
||||
Writeln('Test : $', b0, ' + $', IntToHex(b1_8,2), ' << 1 + $',IntToHex(b9_15,2),' << 9');
|
||||
write(' Expected : $',IntToHex(w,4),' Got : $',IntToHex((AsWord and $7fff),4));
|
||||
if w = (Asword and $7fff) then
|
||||
{$else}
|
||||
Writeln('Test : $', b0, '<< 15 + $', IntToHex(b1_8,2), ' << 6 + $',IntToHex(b9_15,2),' << 1');
|
||||
write(' Expected : $',IntToHex(w,4),' Got : $',IntToHex((AsWord and $fffe),4));
|
||||
if w = (Asword and $fffe) then
|
||||
{$endif}
|
||||
writeln(' OK')
|
||||
else
|
||||
begin
|
||||
writeln(' <--- Fail');
|
||||
halt(1);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure testproc;
|
||||
var
|
||||
Test : TestByteBoundary;
|
||||
begin
|
||||
|
||||
Test.AsBits.bit0 := 0;
|
||||
Test.AsBits.bit1_8 := $FF;
|
||||
Test.AsBits.bit9_15 := 0;
|
||||
writeln(IntToHex(Test.AsWord,4));
|
||||
|
||||
|
||||
|
||||
TestBits($1, $80, $00);
|
||||
TestBits($1, $FE, $00);
|
||||
TestBits($1, $FF, $00);
|
||||
|
||||
|
||||
// These work
|
||||
Test.AsBits.bit0 := 1;
|
||||
Test.AsBits.bit1_8 := $80;
|
||||
Test.AsBits.bit9_15 := 0;
|
||||
|
||||
{$ifdef fpc_little_endian}
|
||||
assert((Test.AsWord and $7fff) = $0101, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $0101');
|
||||
|
||||
Test.AsBits.bit1_8 := $FE;
|
||||
assert((Test.AsWord and $7fff) = $01FD, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $01FD');
|
||||
|
||||
// DOES NOT WORK ...
|
||||
Test.AsBits.bit1_8 := 255;
|
||||
assert((Test.AsWord and $7fff) = $01FF, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $01FF');
|
||||
|
||||
// Rest OK
|
||||
Test.AsWord := 0;
|
||||
Test.AsBits.bit9_15 := 1;
|
||||
assert((Test.AsWord and $7fff) = $0200, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $0200');
|
||||
|
||||
Test.AsBits.bit9_15 := 32;
|
||||
assert((Test.AsWord and $7fff) = $4000, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $4000');
|
||||
|
||||
Test.AsBits.bit9_15 := 62;
|
||||
assert((Test.AsWord and $7fff) = $7C00, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $7C00');
|
||||
|
||||
Test.AsBits.bit9_15 := 63; // Correct
|
||||
assert((Test.AsWord and $7fff) = $7E00, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $7E00');
|
||||
|
||||
Test.AsBits.bit0 := 1;
|
||||
Test.AsBits.bit1_8 := 255;
|
||||
Test.AsBits.bit9_15 := 63;
|
||||
assert((Test.AsWord and $7fff) = $7FFF, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $7FFF');
|
||||
{$else}
|
||||
assert((Test.AsWord and $fffe) = $c000, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $C001');
|
||||
|
||||
Test.AsBits.bit1_8 := $FE;
|
||||
assert((Test.AsWord and $fffe) = $FF00, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $FF00');
|
||||
|
||||
// DOES NOT WORK ...
|
||||
Test.AsBits.bit1_8 := 255;
|
||||
assert((Test.AsWord and $fffe) = $FF80, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $FF80');
|
||||
|
||||
// Rest OK
|
||||
Test.AsWord := 0;
|
||||
Test.AsBits.bit9_15 := 1;
|
||||
assert((Test.AsWord and $fffe) = $0002, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $0002');
|
||||
|
||||
Test.AsBits.bit9_15 := 32;
|
||||
assert((Test.AsWord and $fffe) = $0040, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $0040');
|
||||
|
||||
Test.AsBits.bit9_15 := 62;
|
||||
assert((Test.AsWord and $fffe) = $007C, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $007C');
|
||||
|
||||
Test.AsBits.bit9_15 := 63; // Correct
|
||||
assert((Test.AsWord and $fffe) = $007E, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $007E');
|
||||
|
||||
Test.AsBits.bit0 := 1;
|
||||
Test.AsBits.bit1_8 := 255;
|
||||
Test.AsBits.bit9_15 := 63;
|
||||
assert((Test.AsWord and $fffe) = $FFFE, 'Is: ' + IntToHex(Test.AsWord,4) + ' Should be $FFFE');
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
Test : TestByteBoundary;
|
||||
begin
|
||||
|
||||
with Test, AsBits do begin
|
||||
|
||||
|
||||
|
||||
bit0 := 0;
|
||||
bit1_8 := $FF;
|
||||
bit9_15 := 0;
|
||||
writeln(IntToHex(AsWord,4));
|
||||
|
||||
|
||||
|
||||
TestBits($1, $80, $00);
|
||||
TestBits($1, $FE, $00);
|
||||
TestBits($1, $FF, $00);
|
||||
TestBits($0, $00, $01);
|
||||
|
||||
|
||||
// These work
|
||||
bit0 := 1;
|
||||
bit1_8 := $80;
|
||||
bit9_15 := 0;
|
||||
|
||||
{$ifdef fpc_little_endian}
|
||||
assert((AsWord and $7fff) = $0101, 'Is: ' + IntToHex(Asword,4) + ' Should be $0101');
|
||||
|
||||
bit1_8 := $FE;
|
||||
assert((AsWord and $7fff) = $01FD, 'Is: ' + IntToHex(Asword,4) + ' Should be $01FD');
|
||||
|
||||
// DOES NOT WORK ...
|
||||
bit1_8 := 255;
|
||||
assert((AsWord and $7fff) = $01FF, 'Is: ' + IntToHex(Asword,4) + ' Should be $01FF');
|
||||
|
||||
// Rest OK
|
||||
AsWord := 0;
|
||||
bit9_15 := 1;
|
||||
assert((AsWord and $7fff) = $0200, 'Is: ' + IntToHex(Asword,4) + ' Should be $0200');
|
||||
|
||||
bit9_15 := 32;
|
||||
assert((AsWord and $7fff) = $4000, 'Is: ' + IntToHex(Asword,4) + ' Should be $4000');
|
||||
|
||||
bit9_15 := 62;
|
||||
assert((AsWord and $7fff) = $7C00, 'Is: ' + IntToHex(Asword,4) + ' Should be $7C00');
|
||||
|
||||
bit9_15 := 63; // Correct
|
||||
assert((AsWord and $7fff) = $7E00, 'Is: ' + IntToHex(Asword,4) + ' Should be $7E00');
|
||||
|
||||
bit0 := 1;
|
||||
bit1_8 := 255;
|
||||
bit9_15 := 63;
|
||||
assert((AsWord and $7fff) = $7FFF, 'Is: ' + IntToHex(Asword,4) + ' Should be $7FFF');
|
||||
{$else}
|
||||
assert((AsWord and $fffe) = $c000, 'Is: ' + IntToHex(Asword,4) + ' Should be $C001');
|
||||
|
||||
bit1_8 := $FE;
|
||||
assert((AsWord and $fffe) = $FF00, 'Is: ' + IntToHex(Asword,4) + ' Should be $FF00');
|
||||
|
||||
// DOES NOT WORK ...
|
||||
bit1_8 := 255;
|
||||
assert((AsWord and $fffe) = $FF80, 'Is: ' + IntToHex(Asword,4) + ' Should be $FF80');
|
||||
|
||||
// Rest OK
|
||||
AsWord := 0;
|
||||
bit9_15 := 1;
|
||||
assert((AsWord and $fffe) = $0002, 'Is: ' + IntToHex(Asword,4) + ' Should be $0002');
|
||||
|
||||
bit9_15 := 32;
|
||||
assert((AsWord and $fffe) = $0040, 'Is: ' + IntToHex(Asword,4) + ' Should be $0040');
|
||||
|
||||
bit9_15 := 62;
|
||||
assert((AsWord and $fffe) = $007C, 'Is: ' + IntToHex(Asword,4) + ' Should be $007C');
|
||||
|
||||
bit9_15 := 63; // Correct
|
||||
assert((AsWord and $fffe) = $007E, 'Is: ' + IntToHex(Asword,4) + ' Should be $007E');
|
||||
|
||||
bit0 := 1;
|
||||
bit1_8 := 255;
|
||||
bit9_15 := 63;
|
||||
assert((AsWord and $fffe) = $FFFE, 'Is: ' + IntToHex(Asword,4) + ' Should be $FFFE');
|
||||
{$endif}
|
||||
|
||||
end;
|
||||
testproc;
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user