+ support for bitpacked record constants

  + several array/record bitpacking tests from gpc, most work already

git-svn-id: trunk@6633 -

.gitattributes

@@ -6794,6 +6794,10 @@ tests/test/tparray11.pp svneol=native#text/plain
 tests/test/tparray12.pp svneol=native#text/plain
 tests/test/tparray13.pp svneol=native#text/plain
 tests/test/tparray14.pp svneol=native#text/plain
+tests/test/tparray15.pp svneol=native#text/plain
+tests/test/tparray16.pp svneol=native#text/plain
+tests/test/tparray17.pp svneol=native#text/plain
+tests/test/tparray18.pp svneol=native#text/plain
 tests/test/tparray2.pp svneol=native#text/plain
 tests/test/tparray3.pp svneol=native#text/plain
 tests/test/tparray4.pp svneol=native#text/plain
@@ -6805,6 +6809,9 @@ tests/test/tparray9.pp svneol=native#text/plain
 tests/test/tpftch1.pp svneol=native#text/plain
 tests/test/tprec1.pp svneol=native#text/plain
 tests/test/tprec10.pp svneol=native#text/plain
+tests/test/tprec11.pp svneol=native#text/plain
+tests/test/tprec12.pp svneol=native#text/plain
+tests/test/tprec13.pp svneol=native#text/plain
 tests/test/tprec2.pp svneol=native#text/plain
 tests/test/tprec3.pp svneol=native#text/plain
 tests/test/tprec4.pp svneol=native#text/plain

compiler/ptconst.pas

@@ -49,46 +49,126 @@ implementation
 
 {$maxfpuregisters 0}
 
-    { bitpacks "value" as bitpacked value of bitsize "packedbitsize" and     }
-    { loadsize "loadbitsize" into "curval", which has already been filled up }
-    { to "curbitoffset", and stores the spillover if any into "nextval".     }
-    { It also updates curbitoffset to reflect how many bits of currval are   }
-    { now used (can be > packedbitsize in case of spillover)                 }
-    procedure bitpackval(value: aword; var curval: aword; out nextval: aword; loadbitsize, packedbitsize: byte; var curbitoffset: smallint);
+{*****************************************************************************
+                          Bitpacked value helpers
+*****************************************************************************}
+
+    type
+      tbitpackedval = record
+        curval, nextval: aword;
+        curbitoffset: smallint;
+        loadbitsize,packedbitsize: byte;
+      end;
+
+
+    procedure initbitpackval(out bp: tbitpackedval; packedbitsize: byte);
+      begin
+        bp.curval:=0;
+        bp.nextval:=0;
+        bp.curbitoffset:=0;
+        bp.packedbitsize:=packedbitsize;
+        bp.loadbitsize:=packedbitsloadsize(bp.packedbitsize)*8;
+      end;
+
+
+{$ifopt r+}
+{$defined rangeon}
+{$r-}
+{$endif}
+
+{$ifopt q+}
+{$define overflowon}
+{$q-}
+{$endif}
+    { (values between quotes below refer to fields of bp; fields not         }
+    {  mentioned are unused by this routine)                                 }
+    { bitpacks "value" as bitpacked value of bitsize "packedbitsize" into    }
+    { "curval", which has already been filled up to "curbitoffset", and      }
+    { stores the spillover if any into "nextval". It also updates            }
+    { curbitoffset to reflect how many bits of currval are now used (can be  }
+    { > AIntBits in case of spillover)                                       }
+    procedure bitpackval(value: aword; var bp: tbitpackedval);
       var
-        tmpval: aword;
         shiftcount: longint;
       begin
-        { 1 shl 32/64 = 1 on i386/x86_64 }
-        if (loadbitsize<>AintBits) then
-          tmpval:=(aword(1) shl loadbitsize) - 1
-        else
-          tmpval:=aword(-1);
         if (target_info.endian=endian_big) then
           begin
             { bitpacked format: left-aligned (i.e., "big endian bitness") }
-            curval:=curval or (((value shl (loadbitsize-packedbitsize)) shr curbitoffset) and tmpval);
-            shiftcount:=((loadbitsize-packedbitsize)-curbitoffset);
+            bp.curval:=bp.curval or ((value shl (AIntBits-bp.packedbitsize)) shr bp.curbitoffset);
+            shiftcount:=((AIntBits-bp.packedbitsize)-bp.curbitoffset);
             { carry-over to the next element? }
             if (shiftcount<0) then
-              nextval:=(value and ((aword(1) shl (-shiftcount))-1)) shl
-                       (loadbitsize+shiftcount)
-            else
-              nextval:=0;
+              bp.nextval:=(value and ((aword(1) shl (-shiftcount))-1)) shl
+                          (AIntBits+shiftcount)
           end
         else
           begin
             { bitpacked format: right aligned (i.e., "little endian bitness") }
-            curval:=curval or ((value shl curbitoffset) and tmpval);
+            bp.curval:=bp.curval or (value shl bp.curbitoffset);
             { carry-over to the next element? }
-            if (curbitoffset+packedbitsize>loadbitsize) then
-              nextval:=value shr (loadbitsize-curbitoffset)
+            if (bp.curbitoffset+bp.packedbitsize>AIntBits) then
+              bp.nextval:=value shr (AIntBits-bp.curbitoffset)
+          end;
+        inc(bp.curbitoffset,bp.packedbitsize);
+      end;
+
+{$ifdef rangeon}
+{$r+}
+{$undef rangeon}
+{$endif}
+
+{$ifdef overflowon}
+{$q+}
+{$undef overflowon}
+{$endif}
+
+
+    procedure flush_packed_value(list: tasmlist; var bp: tbitpackedval);
+      var
+        bitstowrite: longint;
+        writeval : byte;
+      begin
+        { these values have to be byte swapped when cross-compiling }
+        { from one endianess to another, but this will be done      }
+        { automatically by the assembler writer                     }
+        if (bp.curbitoffset < AIntBits) then
+          begin
+            { forced flush -> write multiple of loadsize }
+            bitstowrite:=align(bp.curbitoffset,bp.loadbitsize);
+            bp.curbitoffset:=0;
+          end
+        else
+          begin
+            bitstowrite:=AIntBits;
+            dec(bp.curbitoffset,AIntBits);
+          end;
+        while (bitstowrite>=8) do
+          begin
+            if (target_info.endian=endian_little) then
+              begin
+                { write lowest byte }
+                writeval:=byte(bp.curval);
+                bp.curval:=bp.curval shr 8;
+              end
             else
-              nextval:=0;
+              begin
+                { write highest byte }
+                writeval:=bp.curval shr (AIntBits-8);
+                bp.curval:=(bp.curval and (not($ff shl (AIntBits-8)))) shl 8;
+              end;
+            list.concat(tai_const.create_8bit(writeval));
+            dec(bitstowrite,8);
           end;
-        inc(curbitoffset,packedbitsize);
+        bp.curval:=bp.nextval;
+        bp.nextval:=0;
       end;
 
+
+{*****************************************************************************
+                             read typed const
+*****************************************************************************}
+
+
     { this procedure reads typed constants }
     procedure read_typed_const_data(list:tasmlist;def:tdef);
 
@@ -649,29 +729,10 @@ implementation
         end;
 
 
-        procedure flush_packed_value(list: tasmlist; var curval, nextval: aword; loadbitsize: byte; var curbitoffset: smallint);
-          begin
-            { these values have to be byte swapped when cross-compiling }
-            { from one endianess to another, but this will be done      }
-            { automatically by the assembler writer                     }
-            case loadbitsize of
-              8:  list.concat(tai_const.create_8bit(curval));
-              16: list.concat(tai_const.create_16bit(curval));
-              32: list.concat(tai_const.create_32bit(curval));
-              64: list.concat(tai_const.create_64bit(curval));
-              else
-                internalerror(2007022011);
-            end;
-            curval:=nextval;
-            nextval:=0;
-            dec(curbitoffset,loadbitsize);
-          end;
-
-
         { parse a single constant and add it to the packed const info  }
         { represented by curval etc (see explanation of bitpackval for }
         { what the different parameters mean)                          }
-        function parse_single_packed_const(list: tasmlist; def: tdef; var curval: aword; out nextval: aword; loadbitsize, packedbitsize: byte; var curbitoffset: smallint): boolean;
+        function parse_single_packed_const(list: tasmlist; def: tdef; var bp: tbitpackedval): boolean;
           var
             n : tnode;
           begin
@@ -687,9 +748,9 @@ implementation
                 result:=false;
                 exit;
               end;
-            bitpackval(tordconstnode(n).value,curval,nextval,loadbitsize,packedbitsize,curbitoffset);
-            if (curbitoffset>=loadbitsize) then
-              flush_packed_value(list,curval,nextval,loadbitsize,curbitoffset);
+            bitpackval(tordconstnode(n).value,bp);
+            if (bp.curbitoffset>=AIntBits) then
+              flush_packed_value(list,bp);
             n.free;
           end;
 
@@ -697,37 +758,31 @@ implementation
         { parses a packed array constant }
         procedure parse_packed_array_def(list: tasmlist; def: tarraydef);
           var
-            i : aint;
-            curval, nextval: aword;
-            curbitoffset: smallint;
-            packedbitsize,
-            loadbitsize: byte;
+            i  : aint;
+            bp : tbitpackedval;
           begin
             if not(def.elementdef.typ in [orddef,enumdef]) then
               internalerror(2007022010);
             { begin of the array }
             consume(_LKLAMMER);
-            packedbitsize:=def.elepackedbitsize;
-            loadbitsize:=packedbitsloadsize(packedbitsize)*8;
-            curval:=0;
-            curbitoffset:=0;
+            initbitpackval(bp,def.elepackedbitsize);
             i:=def.lowrange;
             { can't use for-loop, fails when cross-compiling from }
             { 32 to 64 bit because i is then 64 bit               }
             while (i<def.highrange) do
               begin
                 { get next item of the packed array }
-                if not parse_single_packed_const(list,def.elementdef,curval,nextval,loadbitsize,packedbitsize,curbitoffset) then
+                if not parse_single_packed_const(list,def.elementdef,bp) then
                   exit;
                 consume(_COMMA);
                 inc(i);
               end;
             { final item }
-            if not parse_single_packed_const(list,def.elementdef,curval,nextval,loadbitsize,packedbitsize,curbitoffset) then
+            if not parse_single_packed_const(list,def.elementdef,bp) then
               exit;
             { flush final incomplete value if necessary }
-            if (curbitoffset <> 0) then
-              flush_packed_value(list,curval,nextval,loadbitsize,curbitoffset);
+            if (bp.curbitoffset <> 0) then
+              flush_packed_value(list,bp);
             consume(_RKLAMMER);
           end;
 
@@ -886,15 +941,12 @@ implementation
           hs      : string;
           sorg,s  : TIDString;
           tmpguid : tguid;
-          curroffset  : aint;
-          error   : boolean;
+          curroffset,
+          fillbytes  : aint;
+          bp   : tbitpackedval;
+          error,
+          is_packed: boolean;
         begin
-          { no packed record support }
-          if is_packed_record_or_object(def) then
-            begin
-              Message(type_e_no_const_packed_record);
-              exit;
-            end;
           { GUID }
           if (def=rec_tguid) and
              ((token=_CSTRING) or (token=_CCHAR) or (token=_ID)) then
@@ -920,6 +972,16 @@ implementation
               n.free;
               exit;
             end;
+          { bitpacked record? }
+          is_packed:=is_packed_record_or_object(def);
+          if (is_packed) then
+            begin
+              { loadbitsize = 8, bitpacked records are always padded to    }
+              { a multiple of a byte. packedbitsize will be set separately }
+              { for each field                                             }
+              initbitpackval(bp,0);
+              bp.loadbitsize:=8;
+            end;
           { normal record }
           consume(_LKLAMMER);
           curroffset:=0;
@@ -982,31 +1044,62 @@ implementation
                 consume_all_until(_SEMICOLON)
               else
                 begin
-
                   { if needed fill (alignment) }
                   if tfieldvarsym(srsym).fieldoffset>curroffset then
-                     for i:=1 to tfieldvarsym(srsym).fieldoffset-curroffset do
-                       list.concat(Tai_const.Create_8bit(0));
-
-                   { new position }
-                   curroffset:=tfieldvarsym(srsym).fieldoffset+tfieldvarsym(srsym).vardef.size;
-
-                   { read the data }
-                   read_typed_const_data(list,tfieldvarsym(srsym).vardef);
-
-                   { keep previous field for checking whether whole }
-                   { record was initialized (JM)                    }
-                   recsym := srsym;
-                   { goto next field }
-                   inc(symidx);
-                   if symidx<def.symtable.SymList.Count then
-                     srsym:=tsym(def.symtable.SymList[symidx])
+                    begin
+                      if not(is_packed) then
+                        fillbytes:=tfieldvarsym(srsym).fieldoffset-curroffset
+                      else
+                        begin
+                          flush_packed_value(list,bp);
+                          { curoffset is now aligned to the next byte }
+                          curroffset:=align(curroffset,8);
+                          { offsets are in bits in this case }
+                          fillbytes:=(tfieldvarsym(srsym).fieldoffset-curroffset) div 8;
+                        end;
+                      for i:=1 to fillbytes do
+                        list.concat(Tai_const.Create_8bit(0))
+                    end;
+
+                  { new position }
+                  curroffset:=tfieldvarsym(srsym).fieldoffset;
+                  if not(is_packed) then
+                    inc(curroffset,tfieldvarsym(srsym).vardef.size)
                    else
-                     srsym:=nil;
+                     inc(curroffset,tfieldvarsym(srsym).vardef.packedbitsize);
+
+                  { read the data }
+                  if not(is_packed) or
+                     { only orddefs and enumdefs are bitpacked, as in gcc/gpc }
+                     not(tfieldvarsym(srsym).vardef.typ in [orddef,enumdef]) then
+                    begin
+                      if is_packed then
+                        begin
+                          flush_packed_value(list,bp);
+                          curroffset:=align(curroffset,8);
+                        end;          
+                      read_typed_const_data(list,tfieldvarsym(srsym).vardef);
+                    end
+                  else
+                    begin
+                      bp.packedbitsize:=tfieldvarsym(srsym).vardef.packedbitsize;
+                      parse_single_packed_const(list,tfieldvarsym(srsym).vardef,bp);
+                    end;
+
+                  { keep previous field for checking whether whole }
+                  { record was initialized (JM)                    }
+                  recsym := srsym;
+                  { goto next field }
+                  inc(symidx);
+                  if symidx<def.symtable.SymList.Count then
+                    srsym:=tsym(def.symtable.SymList[symidx])
+                  else
+                    srsym:=nil;
 
-                   if token=_SEMICOLON then
-                     consume(_SEMICOLON)
-                   else break;
+                  if token=_SEMICOLON then
+                    consume(_SEMICOLON)
+                  else
+                    break;
                 end;
             end;
 
@@ -1019,7 +1112,15 @@ implementation
              ) then
             Message1(parser_w_skipped_fields_after,sorg);
 
-          for i:=1 to def.size-curroffset do
+          if not(is_packed) then
+            fillbytes:=def.size-curroffset
+          else
+            begin
+              flush_packed_value(list,bp);
+              curroffset:=align(curroffset,8);
+              fillbytes:=def.size-(curroffset div 8);
+            end;
+          for i:=1 to fillbytes do
             list.concat(Tai_const.Create_8bit(0));
 
           consume(_RKLAMMER);

tests/test/tparray15.pp

@@ -0,0 +1,28 @@
+{ from gpc testsuite, original name sam7.pas }
+
+{$ifdef fpc}
+{$mode macpas}
+{$endif}
+
+Program Sam7;
+
+Var
+  foo: array [ 'a'..'f' ] of Boolean = ( false, false, true, false, false, false );
+  bar: packed array [ 42..47 ] of Boolean;
+  baz: array [ '0'..'5' ] of Boolean;
+  i: Integer;
+
+begin
+  pack ( foo, 'a', bar );
+  unpack ( bar, baz, '0' );
+  for i:= 0 to 5 do
+    if bar [ 42 + i ] <> baz [ chr(ord('0')+ i) ] then
+      foo [ 'c' ]:= false;
+  if foo [ 'c' ] and bar [ 44 ] then
+    writeln ( 'OK' )
+  else
+    begin
+      writeln ( 'failed ', foo [ 'c' ], ' ', bar [ 44 ] );
+      halt(1)
+    end
+end.

tests/test/tparray16.pp

@@ -0,0 +1,51 @@
+{ from gpc tests, original name pack4.pas }
+
+{$ifdef fpc}
+{$bitpacking on}
+{$endif fpc}
+
+Program PackUnpack;
+
+Var
+  foo: array [ 1..7 ] of Boolean;
+  bar: packed array [ 1..3 ] of Boolean;
+  i: Integer;
+  temp: Boolean;
+
+begin
+  for i:= 1 to 3 do
+    bar [ i ]:= true;
+  for i:= 1 to 7 do
+    foo [ i ]:= false;
+  foo [ 4 ]:= true;
+  foo [ 5 ]:= true;
+  pack ( foo, 3, bar );
+  if bar [ 3 ] and bar [ 2 ] and not bar [ 1 ] then
+    begin
+      for i:= 1 to 3 do
+        begin
+          temp:= not bar [ i ];
+          bar [ i ]:= temp;
+        end { for };
+      unpack ( bar, foo, 5 );
+      if not foo [ 1 ] and not foo [ 2 ] and not foo [ 3 ] and foo [ 4 ]
+         and foo [ 5 ] and not foo [ 6 ] and not foo [ 7 ] then
+        writeln ( 'OK' )
+      else
+        begin
+          write ( 'failed: foo =' );
+          for i:= 1 to 7 do
+            write ( ' ', foo [ i ] );
+          writeln;
+          halt(1);
+        end { else };
+    end { if }
+  else
+    begin
+      write ( 'failed: bar =' );
+      for i:= 1 to 3 do
+        write ( ' ', bar [ i ] );
+      writeln;
+      halt(1);
+    end { else };
+end.

tests/test/tparray17.pp

@@ -0,0 +1,34 @@
+{ from gpc tests, original name: pack6.pas }
+
+{ Introduced the type declaration. Previously, both arrays were `of 0..3'.
+  But EP 6.7.5.4 demands the component types to be the same, not only
+  compatible. GPC detects this now. Frank, 20030417 }
+
+Program Pack6;
+
+{$ifdef fpc}
+{$bitpacking on}
+type
+  Integer = ptrint;
+{$endif}
+
+Type
+  T03 = 0..3;
+
+Var
+  p: packed array [ 1..4 ] of T03;
+  u: array [ 1..4 ] of T03;
+  i: Integer;
+
+begin
+  for i:= 1 to 4 do
+    u [ i ]:= i - 1;
+  pack ( u, 1, p );
+  for i:= 1 to 4 do
+    if p [ i ] <> i - 1 then
+      begin
+        write ( 'failed: p', i, '=', p [ i ], '; ' );
+        halt(1);
+      end;
+  writeln ( 'OK' );
+end.

tests/test/tparray18.pp

@@ -0,0 +1,41 @@
+{ from gpc tests, original name: bitfields.pas }
+
+{$ifdef fpc}
+{$bitpacking on}
+{$endif}
+
+Program BitFields;
+
+Var
+  Foo: packed record
+    b: 0..63;
+    a: 0..1;
+  end { Foo };
+
+  r: packed array [ 40..47 ] of 0..1;
+
+  F: Text;
+
+begin
+  assign(f,'bitfields.txt');
+  rewrite ( F );
+  writeln ( F, '42' );
+  writeln ( F, '0' );
+  writeln ( F, '1' );
+  with Foo do
+    begin
+      reset ( F );
+      readln ( F, b );
+      readln ( F, a );
+      readln ( F, r [ 42 ] );
+      close ( F );
+      erase ( F );
+      if ( b = 42 ) and ( a = 0 ) and ( r [ 42 ] = 1 ) then
+        writeln ( 'OK' )
+      else
+        begin
+          writeln ( 'failed: ', b, ' ', a, ' ', r [ 42 ] );
+          halt(1);
+        end;
+    end { with };
+end.

tests/test/tprec11.pp

@@ -0,0 +1,26 @@
+{ from gpc testsuite, original name: waldek9b.pas }
+
+{$ifdef fpc}
+{$mode macpas}
+{$endif}
+
+program rrr(Output);
+type tr = record end;
+     tp = packed record
+            i : tr;
+          end;
+var a : array [0..15] of tp;
+    pa : packed array [0..15] of tp;
+begin
+  pack (a, 0, pa);
+  if sizeof(a) <> 0 then
+    halt(1);
+  if (sizeof(pa) <> 0) then
+    halt(2);
+  if (sizeof(tr) <> 0) then
+    halt(3);
+  if (sizeof(tp) <> 0) then
+    halt(4);
+  WriteLn ('OK')
+end.
+

tests/test/tprec12.pp

@@ -0,0 +1,169 @@
+{ from gpc tests, original name sam9.pas }
+
+{$ifdef fpc}
+{$mode macpas}
+{$endif}
+
+program sam9;
+
+type
+  e1 = (
+    enum000,
+    enum001,
+    enum002,
+    enum003,
+    enum004,
+    enum005,
+    enum006,
+    enum007,
+    enum008,
+    enum009,
+    enum010,
+    enum011,
+    enum012,
+    enum013,
+    enum014,
+    enum015,
+    enum016,
+    enum017,
+    enum018,
+    enum019,
+    enum020,
+    enum021,
+    enum022,
+    enum023,
+    enum024,
+    enum025,
+    enum026,
+    enum027,
+    enum028,
+    enum029,
+    enum030,
+    enum031,
+    enum032,
+    enum033,
+    enum034,
+    enum035,
+    enum036,
+    enum037,
+    enum038,
+    enum039,
+    enum040,
+    enum041,
+    enum042,
+    enum043,
+    enum044,
+    enum045,
+    enum046,
+    enum047,
+    enum048,
+    enum049,
+    enum050,
+    enum051,
+    enum052,
+    enum053,
+    enum054,
+    enum055,
+    enum056,
+    enum057,
+    enum058,
+    enum059,
+    enum060,
+    enum061,
+    enum062,
+    enum063,
+    enum064,
+    enum065,
+    enum066,
+    enum067,
+    enum068,
+    enum069,
+    enum070,
+    enum071,
+    enum072,
+    enum073,
+    enum074,
+    enum075,
+    enum076,
+    enum077,
+    enum078,
+    enum079,
+    enum080,
+    enum081,
+    enum082,
+    enum083,
+    enum084,
+    enum085,
+    enum086,
+    enum087,
+    enum088,
+    enum089,
+    enum090,
+    enum091,
+    enum092,
+    enum093,
+    enum094,
+    enum095,
+    enum096,
+    enum097,
+    enum098,
+    enum099,
+    enum100,
+    enum101,
+    enum102,
+    enum103,
+    enum104,
+    enum105,
+    enum106,
+    enum107,
+    enum108,
+    enum109,
+    enum110,
+    enum111,
+    enum112,
+    enum113,
+    enum114,
+    enum115,
+    enum116,
+    enum117,
+    enum118,
+    enum119,
+    enum120,
+    enum121,
+    enum122,
+    enum123,
+    enum124,
+    enum125,
+    enum126,
+    enum127,
+    enum128 { Remove this and it works !}
+  );
+
+  r1 = 0 .. 128;
+
+  t1 = packed record { has to be packed }
+    case integer of
+        1: (f1: e1);
+        2: (f2: r1);
+      end;
+
+var
+  v1: t1;
+
+procedure foo;
+begin
+  v1.f1 := enum000;
+  v1.f2 := 127;
+  v1.f2 := 128;
+end;
+
+begin
+  foo;
+  if v1.f1 = enum128 then
+    writeln ( 'OK' )
+  else
+    begin
+      writeln ( 'failed' );
+      halt(1)
+    end
+end.

tests/test/tprec13.pp

@@ -0,0 +1,38 @@
+{ from gpc tests, original name pack1.pas }
+
+{$ifdef fpc}
+{$bitpacking on}
+{$endif}
+
+Program Pack1;
+
+Var
+  r: packed record
+       a, b: Boolean;
+       c: false..true;
+       d: 0..3;
+       e: -3..3;
+       i: Integer;
+     end { r };
+  rb: Byte absolute r;
+
+var
+  i: integer;
+begin
+  rb:= 0;
+  with r do
+    begin
+      a:= false;
+      b:= true;
+      c:= false;
+      d:= 2;
+      e:= -1;
+    end { with };
+  if ( SizeOf ( r ) = 1 + SizeOf (Integer) ) and ( rb = {$ifdef FPC_BIG_ENDIAN} %01010111 {$else} %11110010 {$endif} ) then
+    writeln ( 'OK' )
+  else
+    begin
+      writeln ( 'failed ', SizeOf (r), ' ', SizeOf (Integer), ' ', rb );
+      halt(1);
+    end;
+end.