* 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 -

.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

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;

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);

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.
+

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.
+