diff --git a/.gitattributes b/.gitattributes
index a393cedcfe..df24d4a873 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -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
diff --git a/compiler/cgobj.pas b/compiler/cgobj.pas
index ce2308f1ff..93876a1c6b 100644
--- a/compiler/cgobj.pas
+++ b/compiler/cgobj.pas
@@ -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;
diff --git a/compiler/ncgmem.pas b/compiler/ncgmem.pas
index f1befe56e5..77790e8030 100644
--- a/compiler/ncgmem.pas
+++ b/compiler/ncgmem.pas
@@ -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);
diff --git a/tests/test/tprec22.pp b/tests/test/tprec22.pp
new file mode 100644
index 0000000000..9be8a195a6
--- /dev/null
+++ b/tests/test/tprec22.pp
@@ -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.
+
diff --git a/tests/test/tprec23.pp b/tests/test/tprec23.pp
new file mode 100644
index 0000000000..6de5ca1827
--- /dev/null
+++ b/tests/test/tprec23.pp
@@ -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.
+