+ support for packed array constants

git-svn-id: trunk@6583 -

.gitattributes

@@ -6791,6 +6791,8 @@ tests/test/tparray1.pp svneol=native#text/plain
 tests/test/tparray10.pp svneol=native#text/plain
 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/tparray2.pp svneol=native#text/plain
 tests/test/tparray3.pp svneol=native#text/plain
 tests/test/tparray4.pp svneol=native#text/plain

compiler/ptconst.pas

@@ -49,6 +49,46 @@ 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);
+      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);
+            { carry-over to the next element? }
+            if (shiftcount<0) then
+              nextval:=(value and ((aword(1) shl (-shiftcount))-1)) shl
+                       (loadbitsize+shiftcount)
+            else
+              nextval:=0;
+          end
+        else
+          begin
+            { bitpacked format: right aligned (i.e., "little endian bitness") }
+            curval:=curval or ((value shl curbitoffset) and tmpval);
+            { carry-over to the next element? }
+            if (curbitoffset+packedbitsize>loadbitsize) then
+              nextval:=value shr (loadbitsize-curbitoffset)
+            else
+              nextval:=0;
+          end;
+        inc(curbitoffset,packedbitsize);
+      end;
+
     { this procedure reads typed constants }
     procedure read_typed_const_data(list:tasmlist;def:tdef);
 
@@ -608,6 +648,96 @@ implementation
           n.free;
         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;
+          var
+            n : tnode;
+          begin
+            result:=true;
+            n:=comp_expr(true);
+            if (n.nodetype <> ordconstn) or
+               not equal_defs(n.resultdef,def) and
+               not is_subequal(n.resultdef,def) then
+              begin
+                n.free;
+                incompatibletypes(n.resultdef,def);
+                consume_all_until(_SEMICOLON);
+                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);
+            n.free;
+          end;
+
+
+        { parses a packed array constant }
+        procedure parse_packed_array_def(list: tasmlist; def: tarraydef);
+          var
+            i : aint;
+            loadmask: aword;
+            curval, nextval: aword;
+            curbitoffset: smallint;
+            packedbitsize,
+            loadbitsize: byte;
+          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;
+            { 1 shl 32/64 = 1 on i386/x86_64 }
+            if (loadbitsize*8 <> sizeof(aword)) then
+              loadmask:=aword(1) shl loadbitsize
+            else
+              loadmask:=aword(-1);
+            curval:=0;
+            curbitoffset:=0;
+            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
+                  exit;
+                consume(_COMMA);
+                inc(i);
+              end;
+            { final item }
+            if not parse_single_packed_const(list,def.elementdef,curval,nextval,loadbitsize,packedbitsize,curbitoffset) then
+              exit;
+            { flush final incomplete value if necessary }
+            if (curbitoffset <> 0) then
+              flush_packed_value(list,curval,nextval,loadbitsize,curbitoffset);
+            consume(_RKLAMMER);
+          end;
+
+
         procedure parse_arraydef(list:tasmlist;def:tarraydef);
         var
           n : tnode;
@@ -623,11 +753,11 @@ implementation
               consume(_NIL);
               list.concat(Tai_const.Create_sym(nil));
             end
-          { no packed array constants supported }
-          else if is_packed_array(def) then
+          { packed array constant }
+          else if is_packed_array(def) and
+                  (def.elepackedbitsize mod 8 <> 0)  then
             begin
-              Message(type_e_no_const_packed_array);
-              consume_all_until(_RKLAMMER);
+              parse_packed_array_def(list,def);
             end
           { normal array const between brackets }
           else if try_to_consume(_LKLAMMER) then

tests/test/tparray13.pp

@@ -0,0 +1,120 @@
+{$mode macpas}
+
+{$r-}
+
+procedure error(l: longint);
+begin
+  writeln('error near ',l);
+  halt(1);
+end;
+
+
+procedure test8bit;
+type
+  ta = 0..1;
+const
+  b: packed array[0..9] of ta = (1,0,1,1,1,0,1,1,1,0);
+  results: array[0..9] of ta = (1,0,1,1,1,0,1,1,1,0);
+var
+  i: longint;
+begin
+  if (sizeof(b)<>2) then
+   error(1);
+  for i := low(results) to high(results) do
+    if b[i] <> results[i] then
+      error(7);
+end;
+
+
+procedure test8to16bit;
+type
+  ta = 0..7;
+const
+  b: packed array[0..5] of ta = (2,4,1,7,5,1);
+  results: array[0..5] of ta = (2,4,1,7,5,1);
+var
+  i: longint;
+begin
+  if (sizeof(b)<>3) then
+    error(16);
+  for i := low(results) to high(results) do
+    if b[i] <> results[i] then
+      error(17);
+end;
+
+
+procedure test16bit;
+type
+  ta = 0..511;
+const
+  b: packed array[0..4] of ta = (356,39,485,100,500);
+  results: array[0..4] of ta = (356,39,485,100,500);
+var
+  i: longint;
+begin
+  if (sizeof(b)<>6) then
+    error(26);
+  for i := low(results) to high(results) do
+    if b[i] <> results[i] then
+      error(27);
+end;
+
+
+procedure test16to24bit;
+type
+  ta = 0..2047;
+const
+  b: packed array[0..4] of ta = (1000,67,853,512,759);
+  results: array[0..4] of ta = (1000,67,853,512,759);
+var
+  i: longint;
+begin
+  if (sizeof(b)<>7) then
+    error(36);
+  for i := low(results) to high(results) do
+    if b[i] <> results[i] then
+      error(37);
+end;
+
+
+procedure test32bit;
+type
+  ta = 0..(1 shl 19) - 1;
+const
+  b: packed array[0..4] of ta = ($0002F687,$00032222,$000178EE,$000057970,$0007E1D2);
+  results: array[0..4] of ta = ($0002F687,$00032222,$000178EE,$000057970,$0007E1D2);
+var
+  i: longint;
+begin
+  if (sizeof(b)<>12) then
+    error(46);
+  for i := low(results) to high(results) do
+    if b[i] <> results[i] then
+      error(47);
+end;
+
+
+procedure test32to40bit;
+type
+  ta = 0..$7fffffff;
+const
+  b: packed array[0..4] of ta = ($71567851,$56789ABD,$50F11178,$39D68DDC,$6C7A5A7);
+  results: array[0..4] of ta = ($71567851,$56789ABD,$50F11178,$39D68DDC,$6C7A5A7);
+var
+  i: longint;
+begin
+  if (sizeof(b)<>20) then
+    error(56);
+  for i := low(results) to high(results) do
+    if b[i] <> results[i] then
+      error(57);
+end;
+
+begin
+  test8bit;
+  test8to16bit;
+  test16bit;
+  test16to24bit;
+  test32bit;
+  test32to40bit;
+end.

tests/test/tparray14.pp

@@ -0,0 +1,65 @@
+{ based on gpc test pvs1 }
+{ FLAG --extended-pascal }
+
+{TEST 6.6.5.4-1, CLASS=CONFORMANCE}
+
+{ This program tests that pack and unpack are
+  implemented in this compiler as according to the
+  Standard.
+  The compiler fails if the program does not compile. }
+
+program t6p6p5p4d1(output);
+
+{$mode macpas}
+
+type
+   colourtype = (red,pink,orange,yellow,green,blue);
+
+var
+   unone    : array[3..24] of char;
+   pacy     : array[1..4] of char;
+   pactwo   : packed array[6..7] of colourtype;
+   i        : integer;
+   colour   : colourtype;
+   s: string;
+
+const
+   pacone   : packed array[1..4] of char = 'ABCD';
+   untwo    : array[4..8] of colourtype = (red,pink,orange,yellow,green);
+begin
+   pacy:=pacone;
+   if pacy <> 'ABCD' then
+     halt(1);
+   s := pacone;
+   unpack(pacone,unone,5);
+   if (unone[3] <> #0) or
+      (unone[4] <> #0) or
+      (unone[5] <> 'A') or
+      (unone[6] <> 'B') or
+      (unone[7] <> 'C') or
+      (unone[8] <> 'D') or
+      (unone[9] <> #0) or
+      (unone[10] <> #0) or
+      (unone[11] <> #0) then
+     halt(1);
+   colour:=red;
+   for i:=4 to 8 do
+   begin
+      if (untwo[i]<>colour) then
+        halt(2);
+      colour:=succ(colour)
+   end;
+   pack(untwo,5,pactwo);
+   if (pactwo[6] <> pink) or
+      (pactwo[7] <> orange) then
+     halt(1);
+   writeln('unone[5] = ''', unone[5], ''' = ', ord(unone[5]));
+   if unone[5]='A' then
+      writeln(' PASS...6.6.5.4-1')
+   else
+     begin
+       writeln(' FAIL...6.6.5.4-1');
+       halt(1);
+     end;
+end.
+