+ some more working packed array tests

git-svn-id: trunk@4444 -

.gitattributes

@@ -6140,11 +6140,15 @@ tests/test/tpackrec.pp svneol=native#text/plain
 tests/test/tpara1.pp svneol=native#text/plain
 tests/test/tpara2.pp svneol=native#text/plain
 tests/test/tparray1.pp svneol=native#text/plain
+tests/test/tparray10.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
 tests/test/tparray5.pp svneol=native#text/plain
 tests/test/tparray6.pp svneol=native#text/plain
+tests/test/tparray7.pp svneol=native#text/plain
+tests/test/tparray8.pp svneol=native#text/plain
+tests/test/tparray9.pp svneol=native#text/plain
 tests/test/tpftch1.pp svneol=native#text/plain
 tests/test/tprocext.pp svneol=native#text/plain
 tests/test/tprocvar1.pp svneol=native#text/plain

tests/test/tparray10.pp

@@ -0,0 +1,56 @@
+{ 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;
+   pacone   : packed array[1..4] of char;
+   untwo    : array[4..8] of colourtype;
+   pactwo   : packed array[6..7] of colourtype;
+   i        : integer;
+   colour   : colourtype;
+begin
+   pacone:='ABCD';
+   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
+      untwo[i]:=colour;
+      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.
+

tests/test/tparray7.pp

@@ -0,0 +1,247 @@
+{$mode macpas}
+
+{$r-}
+
+procedure error(l: longint);
+begin
+  writeln('error near ',l);
+  halt(1);
+end;
+
+
+procedure test8bit;
+type
+  ta = 0..1;
+  tb = packed array[0..999] of ta;
+  tc = array[0..124] of byte;
+const
+  results: array[0..9] of ta = (1,0,1,1,1,0,1,1,1,0);
+var
+  a: ta;
+  b: tb;
+  i,j: longint;
+begin
+  fillchar(b,sizeof(b),0);
+  for i := low(results) to high(results) do
+    begin
+      b[i] := results[i];
+      for j := succ(i) to high(results) do
+        if b[j] <> 0 then
+          error(201);
+      if b[i] <> results[i] then
+        error(202);
+    end;
+  if (b[0] <> results[0]) then
+    error(1);
+  if (b[1] <> results[1]) then
+    error(2);
+  if (b[2] <> results[2]) then
+    error(3);
+  if (b[3] <> results[3]) then
+    error(4);
+  if (b[4] <> results[4]) then
+    error(5);
+  for i := low(results) to high(results) do
+    if b[i] <> results[i] then
+      error(7);
+end;
+
+
+procedure test8to16bit;
+type
+  ta = 0..7;
+  tb = packed array[0..1000] of ta;
+const
+  results: array[0..5] of ta = (2,4,1,7,5,1);
+var
+  a: ta;
+  b: tb;
+  i,j: longint;
+begin
+  fillchar(b,sizeof(b),$ff);
+  for i := low(results) to high(results) do
+    begin
+      b[i] := results[i];
+      for j := succ(i) to high(results) do
+        if b[j] <> high(ta) then
+          error(211);
+      if b[i] <> results[i] then
+        error(212);
+    end;
+  if (b[0] <> results[0]) then
+    error(11);
+  if (b[1] <> results[1]) then
+    error(12);
+  if (b[2] <> results[2]) then
+    error(13);
+  if (b[3] <> results[3]) then
+    error(14);
+  if (b[4] <> results[4]) then
+    error(15);
+  if (b[5] <> results[5]) then
+    error(155);
+  for i := low(results) to high(results) do
+    if b[i] <> results[i] then
+      error(17);
+end;
+
+
+procedure test16bit;
+type
+  ta = 0..511;
+  tb = packed array[0..799] of ta;
+  tc = array[0..899] of byte;
+const
+  results: array[0..4] of ta = (356,39,485,100,500);
+var
+  a: ta;
+  b: tb;
+  i,j: longint;
+begin
+  fillchar(b,sizeof(b),$ff);
+  for i := low(results) to high(results) do
+    begin
+      b[i] := results[i];
+      for j := succ(i) to high(results) do
+        if b[j] <> high(ta) then
+          error(221);
+      if b[i] <> results[i] then
+        error(222);
+    end;
+  if (b[0] <> results[0]) then
+    error(21);
+  if (b[1] <> results[1]) then
+    error(22);
+  if (b[2] <> results[2]) then
+    error(23);
+  if (b[3] <> results[3]) then
+    error(24);
+  if (b[4] <> results[4]) then
+    error(25);
+  for i := low(results) to high(results) do
+    if b[i] <> results[i] then
+      error(27);
+end;
+
+
+procedure test16to24bit;
+type
+  ta = 0..2047;
+  tb = packed array[0..799] of ta;
+  tc = array[0..1099] of byte;
+const
+  results: array[0..4] of ta = (1000,67,853,512,759);
+var
+  a: ta;
+  b: tb;
+  i,j: longint;
+begin
+  fillchar(b,sizeof(b),$ff);
+  for i := low(results) to high(results) do
+    begin
+      b[i] := results[i];
+      for j := succ(i) to high(results) do
+        if b[j] <> high(ta) then
+          error(231);
+      if b[i] <> results[i] then
+        error(232);
+    end;
+  if (b[0] <> results[0]) then
+    error(31);
+  if (b[1] <> results[1]) then
+    error(32);
+  if (b[2] <> results[2]) then
+    error(33);
+  if (b[3] <> results[3]) then
+    error(34);
+  if (b[4] <> results[4]) then
+    error(35);
+  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;
+  tb = packed array[0..799] of ta;
+  tc = array[0..1899] of byte;
+const
+  results: array[0..4] of ta = ($0002F687,$00032222,$000178EE,$000057970,$0007E1D2);
+var
+  a: ta;
+  b: tb;
+  i,j: longint;
+begin
+  fillchar(b,sizeof(b),$ff);
+  for i := low(results) to high(results) do
+    begin
+      b[i] := results[i];
+      for j := succ(i) to high(results) do
+        if b[j] <> high(ta) then
+          error(241);
+      if b[i] <> results[i] then
+        error(242);
+    end;
+  if (b[0] <> results[0]) then
+    error(41);
+  if (b[1] <> results[1]) then
+    error(42);
+  if (b[2] <> results[2]) then
+    error(43);
+  if (b[3] <> results[3]) then
+    error(44);
+  if (b[4] <> results[4]) then
+    error(45);
+  for i := low(results) to high(results) do
+    if b[i] <> results[i] then
+      error(47);
+end;
+
+
+procedure test32to40bit;
+type
+  ta = 0..$7fffffff;
+  tb = packed array[0..799] of ta;
+  tc = array[0..3099] of byte;
+const
+  results: array[0..4] of ta = ($71567851,$56789ABD,$50F11178,$39D68DDC,$6C7A5A7);
+var
+  a: ta;
+  b: tb;
+  i,j: longint;
+begin
+  fillchar(b,sizeof(b),$ff);
+  for i := low(results) to high(results) do
+    begin
+      b[i] := results[i];
+      for j := succ(i) to high(results) do
+        if b[j] <> high(ta) then
+          error(251);
+      if b[i] <> results[i] then
+        error(252);
+    end;
+  if (b[0] <> results[0]) then
+    error(51);
+  if (b[1] <> results[1]) then
+    error(52);
+  if (b[2] <> results[2]) then
+    error(53);
+  if (b[3] <> results[3]) then
+    error(54);
+  if (b[4] <> results[4]) then
+    error(55);
+  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/tparray8.pp

@@ -0,0 +1,14 @@
+{ %fail }
+
+{ from gpc test suite }
+program PCErrorA;
+
+{$r+}
+var
+chs :bitpacked array [1..10] of char;
+ch1 :array[1..10] of char;
+
+begin
+pack(ch1,2,chs);  { WRONG }
+end.
+

tests/test/tparray9.pp

@@ -0,0 +1,13 @@
+{ %fail }
+
+program PCErrorB;
+{$bitpacking on}
+{$r+}
+
+var
+chs :packed array [1..10] of char;
+ch1 :array[1..10] of char;
+
+begin
+unpack(chs,ch1,2);  { WRONG }
+end.