Merged revisions 7608-7610,7614,7621 via svnmerge from

svn+ssh://[email protected]/FPC/svn/fpc/trunk

........
r7608 | jonas | 2007-06-09 19:23:11 +0200 (Sat, 09 Jun 2007) | 2 lines

  * enable break and continue in macpas mode (mantis #9032)

........
r7609 | jonas | 2007-06-09 19:52:20 +0200 (Sat, 09 Jun 2007) | 5 lines

  * allow taking the address of fields of packed records iff
   * their offset is a multiple of 8 bits; and
   * their size is a multiple of 8 bits; and
   * if it's a range type, the size is also a power of 2

........
r7610 | jonas | 2007-06-09 20:13:04 +0200 (Sat, 09 Jun 2007) | 4 lines

  * don't allow taking the address of ordinal bitpacked array elements
    whose size is not a power of two
  + some more packed array/record tests

........
r7614 | jonas | 2007-06-09 21:48:14 +0200 (Sat, 09 Jun 2007) | 5 lines

  * fixed some record size checks
   (some are still broken, but can't be fixed currently because
    def.size/sym.getsize return an aint, which means low(aint)
    in case of structures with a size = high(aint)+1)

........
r7621 | jonas | 2007-06-10 13:55:05 +0200 (Sun, 10 Jun 2007) | 3 lines

  * changed so it still fails now that you can take the address of some
    fields of bitpacked records

........

git-svn-id: branches/fixes_2_2@7622 -

.gitattributes

@@ -6785,6 +6785,10 @@ tests/test/tparray19.pp svneol=native#text/plain
 tests/test/tparray2.pp svneol=native#text/plain
 tests/test/tparray20.pp svneol=native#text/plain
 tests/test/tparray21.pp svneol=native#text/plain
+tests/test/tparray22.pp svneol=native#text/plain
+tests/test/tparray23.pp svneol=native#text/plain
+tests/test/tparray24.pp svneol=native#text/plain
+tests/test/tparray25.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
@@ -6799,7 +6803,13 @@ 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/tprec14.pp svneol=native#text/plain
+tests/test/tprec15.pp svneol=native#text/plain
+tests/test/tprec16.pp svneol=native#text/plain
+tests/test/tprec17.pp svneol=native#text/plain
+tests/test/tprec18.pp svneol=native#text/plain
+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/tprec3.pp svneol=native#text/plain
 tests/test/tprec4.pp svneol=native#text/plain
 tests/test/tprec5.pp svneol=native#text/plain
@@ -7213,6 +7223,10 @@ tests/webtbf/tw8780a.pp svneol=native#text/plain
 tests/webtbf/tw8780b.pp svneol=native#text/plain
 tests/webtbf/tw8780c.pp svneol=native#text/plain
 tests/webtbf/tw8781.pp svneol=native#text/plain
+tests/webtbf/tw9039a.pp svneol=native#text/plain
+tests/webtbf/tw9039b.pp svneol=native#text/plain
+tests/webtbf/tw9039c.pp svneol=native#text/plain
+tests/webtbf/tw9039d.pp svneol=native#text/plain
 tests/webtbf/uw0744.pp svneol=native#text/plain
 tests/webtbf/uw0840a.pp svneol=native#text/plain
 tests/webtbf/uw0840b.pp svneol=native#text/plain

compiler/htypechk.pas

@@ -921,7 +921,8 @@ implementation
         gotderef : boolean;
         fromdef,
         todef    : tdef;
-        errmsg   : longint;
+        errmsg,
+        temp     : longint;
       begin
         if valid_const in opts then
           errmsg:=type_e_variable_id_expected
@@ -1084,7 +1085,9 @@ implementation
                     not(valid_packed in opts) and
                     (tvecnode(hp).left.resultdef.typ = arraydef) and
                     (ado_IsBitPacked in tarraydef(tvecnode(hp).left.resultdef).arrayoptions) and
-                    (tarraydef(tvecnode(hp).left.resultdef).elepackedbitsize mod 8 <> 0) then
+                    ((tarraydef(tvecnode(hp).left.resultdef).elepackedbitsize mod 8 <> 0) or
+                     (is_ordinal(tarraydef(tvecnode(hp).left.resultdef).elementdef) and
+                      not ispowerof2(tarraydef(tvecnode(hp).left.resultdef).elepackedbitsize div 8,temp))) then
                    begin
                      if report_errors then
                        if (valid_property in opts) then
@@ -1134,7 +1137,10 @@ implementation
                  { only check first (= outermost) subscriptn }
                  if not gotsubscript and
                     not(valid_packed in opts) and
-                    is_packed_record_or_object(tsubscriptnode(hp).left.resultdef) then
+                    is_packed_record_or_object(tsubscriptnode(hp).left.resultdef) and
+                    ((tsubscriptnode(hp).vs.fieldoffset mod 8 <> 0) or
+                     (is_ordinal(tsubscriptnode(hp).resultdef) and
+                      not ispowerof2(tsubscriptnode(hp).resultdef.packedbitsize div 8,temp)))  then
                    begin
                      if report_errors then
                        if (valid_property in opts) then

compiler/pexpr.pas

@@ -434,24 +434,12 @@ implementation
 
           in_break :
             begin
-              if not (m_mac in current_settings.modeswitches) then
-               statement_syssym:=cbreaknode.create
-              else
-                begin
-                  Message1(sym_e_id_not_found, orgpattern);
-                  statement_syssym:=cerrornode.create;
-                end;
+              statement_syssym:=cbreaknode.create
             end;
 
           in_continue :
             begin
-              if not (m_mac in current_settings.modeswitches) then
-                statement_syssym:=ccontinuenode.create
-              else
-                begin
-                  Message1(sym_e_id_not_found, orgpattern);
-                  statement_syssym:=cerrornode.create;
-                end;
+              statement_syssym:=ccontinuenode.create
             end;
 
           in_leave :

compiler/symtable.pas

@@ -791,12 +791,14 @@ implementation
               begin
                 databitsize:=_datasize*8;
                 sym.fieldoffset:=databitsize;
+                if (l>high(aint) div 8) then
+                  Message(sym_e_segment_too_large);
                 l:=l*8;
               end;
             { bit packed records are limited to high(aint) bits }
             { instead of bytes to avoid double precision        }
             { arithmetic in offset calculations                 }
-            if (int64(l)+sym.fieldoffset)>high(aint) then
+            if int64(l)>high(aint)-sym.fieldoffset then
               begin
                 Message(sym_e_segment_too_large);
                 _datasize:=high(aint);
@@ -843,7 +845,7 @@ implementation
           varalignfield:=used_align(varalign,current_settings.alignment.recordalignmin,fieldalignment);
 
         sym.fieldoffset:=align(_datasize,varalignfield);
-        if (int64(l)+sym.fieldoffset)>high(aint) then
+        if l>high(aint)-sym.fieldoffset then
           begin
             Message(sym_e_segment_too_large);
             _datasize:=high(aint);
@@ -934,7 +936,8 @@ implementation
         def : tdef;
         i,
         varalignrecord,varalign,
-        storesize,storealign : longint;
+        storesize,storealign : aint;
+        bitsize: aint;
       begin
         storesize:=_datasize;
         storealign:=fieldalignment;
@@ -963,7 +966,16 @@ implementation
                 { bit packed records are limited to high(aint) bits }
                 { instead of bytes to avoid double precision        }
                 { arithmetic in offset calculations                 }
-                if databitsize>high(aint) then
+                if is_ordinal(tfieldvarsym(sym).vardef) then
+                  bitsize:=tfieldvarsym(sym).getpackedbitsize
+                else
+                  begin
+                    bitsize:=tfieldvarsym(sym).getsize;
+                    if (bitsize>high(aint) div 8) then
+                      Message(sym_e_segment_too_large);
+                    bitsize:=bitsize*8;
+                  end;
+                if bitsize>high(aint)-databitsize then
                   begin
                     Message(sym_e_segment_too_large);
                     _datasize:=high(aint);
@@ -978,12 +990,13 @@ implementation
               end
             else
               begin
-                _datasize:=tfieldvarsym(sym).fieldoffset+offset;
-                if _datasize>high(aint) then
+                if tfieldvarsym(sym).getsize>high(aint)-_datasize then
                   begin
                     Message(sym_e_segment_too_large);
                     _datasize:=high(aint);
-                  end;
+                  end
+                else
+                  _datasize:=tfieldvarsym(sym).fieldoffset+offset;
                 { update address }
                 tfieldvarsym(sym).fieldoffset:=_datasize;
                 { update alignment of this record }

tests/test/tparray22.pp

@@ -0,0 +1,16 @@
+{ %fail }
+
+type
+  trange = 0..$ffffff;
+  tarr = bitpacked array[0..20] of trange;
+
+procedure p(var a: trange);
+begin
+end;
+
+var
+  a: tarr;
+begin
+  a[0]:=5;
+  p(a[0]);
+end.

tests/test/tparray23.pp

@@ -0,0 +1,17 @@
+{ %fail }
+
+type
+  trange = 0..$ffffff;
+  prange = ^trange;
+  tarr = bitpacked array[0..20] of trange;
+
+procedure p(a: prange);
+begin
+end;
+
+var
+  a: tarr;
+begin
+  a[0]:=5;
+  p(@a[0]);
+end.

tests/test/tparray24.pp

@@ -0,0 +1,17 @@
+type
+  tstr = string[2];
+  tarr = bitpacked array[0..20] of tstr;
+
+procedure p(var a: tstr);
+begin
+  a := 'ab';
+end;
+
+var
+  a: tarr;
+begin
+  a[0]:='gh';
+  p(a[0]);
+  if (a[0]<>'ab') then
+    halt(1);
+end.

tests/test/tparray25.pp

@@ -0,0 +1,18 @@
+type
+  tstr = string[2];
+  pstr = ^tstr;
+  tarr = bitpacked array[0..20] of tstr;
+
+procedure p(a: pstr);
+begin
+  a^ := 'ab';
+end;
+
+var
+  a: tarr;
+begin
+  a[0]:='gh';
+  p(@a[0]);
+  if (a[0]<>'ab') then
+    halt(1);
+end.

tests/test/tprec15.pp

@@ -0,0 +1,42 @@
+type
+  tr = bitpacked record
+    a,b,c: byte;
+    d,e:0..15;
+    f: byte;
+    g: 0..$ffffff; { 3 bytes }
+    h: byte;
+  end;
+
+procedure p(var b: byte);
+begin
+  b := $12
+end;
+
+var
+  r: tr;
+begin
+  fillchar(r,sizeof(r),0);
+  p(r.a);
+  if (r.a<>$12) then
+    halt(1);
+
+  fillchar(r,sizeof(r),0);
+  p(r.b);
+  if (r.b<>$12) then
+    halt(1);
+
+  fillchar(r,sizeof(r),0);
+  p(r.c);
+  if (r.c<>$12) then
+    halt(1);
+
+  fillchar(r,sizeof(r),0);
+  p(r.f);
+  if (r.f<>$12) then
+    halt(1);
+
+  fillchar(r,sizeof(r),0);
+  p(r.h);
+  if (r.h<>$12) then
+    halt(1);
+end.

tests/test/tprec16.pp

@@ -0,0 +1,21 @@
+{ %fail }
+
+type
+  tr = bitpacked record
+    a,b,c: byte;
+    d,e:0..15;
+    f: byte;
+    g: 0..$ffffff; { 3 bytes }
+    h: byte;
+  end;
+
+procedure p(var b: byte);
+begin
+  b := $12
+end;
+
+var
+  r: tr;
+begin
+  p(r.d);
+end.

tests/test/tprec17.pp

@@ -0,0 +1,23 @@
+{ %fail }
+
+type
+  trange = 0..$ffffff;
+
+  tr = bitpacked record
+    a,b,c: byte;
+    d,e:0..15;
+    f: byte;
+    g: trange; { 3 bytes }
+    h: byte;
+  end;
+
+procedure p(var b: trange);
+begin
+  b := $12
+end;
+
+var
+  r: tr;
+begin
+  p(r.g);
+end.

tests/test/tprec18.pp

@@ -0,0 +1,21 @@
+{ %fail }
+
+type
+  tr = bitpacked record
+    a,b,c: byte;
+    d,e:0..15;
+    f: byte;
+    g: 0..$ffffff; { 3 bytes }
+    h: byte;
+  end;
+
+procedure p(var b: byte);
+begin
+  b := $12
+end;
+
+var
+  r: tr;
+begin
+  p(r.e);
+end.

tests/test/tprec19.pp

@@ -0,0 +1,44 @@
+type
+  pbyte = ^byte;
+
+  tr = bitpacked record
+    a,b,c: byte;
+    d,e:0..15;
+    f: byte;
+    g: 0..$ffffff; { 3 bytes }
+    h: byte;
+  end;
+
+procedure p(b: pbyte);
+begin
+  b^ := $12
+end;
+
+var
+  r: tr;
+begin
+  fillchar(r,sizeof(r),0);
+  p(@r.a);
+  if (r.a<>$12) then
+    halt(1);
+
+  fillchar(r,sizeof(r),0);
+  p(@r.b);
+  if (r.b<>$12) then
+    halt(1);
+
+  fillchar(r,sizeof(r),0);
+  p(@r.c);
+  if (r.c<>$12) then
+    halt(1);
+
+  fillchar(r,sizeof(r),0);
+  p(@r.f);
+  if (r.f<>$12) then
+    halt(1);
+
+  fillchar(r,sizeof(r),0);
+  p(@r.h);
+  if (r.h<>$12) then
+    halt(1);
+end.

tests/test/tprec20.pp

@@ -0,0 +1,23 @@
+{ %fail }
+
+type
+  pbyte = ^byte;
+
+  tr = bitpacked record
+    a,b,c: byte;
+    d,e:0..15;
+    f: byte;
+    g: 0..$ffffff; { 3 bytes }
+    h: byte;
+  end;
+
+procedure p(b: pbyte);
+begin
+  b^ := $12
+end;
+
+var
+  r: tr;
+begin
+  p(@r.d);
+end.

tests/webtbf/tw7438.pp

@@ -7,8 +7,8 @@ interface
 
 type
   tr = bitpacked record
-    l1: longint;
-    l2: longint;
+    l1: 0..15;
+    l2: 0..15;
   end;
 
 

tests/webtbf/tw9039a.pp

@@ -0,0 +1,17 @@
+{ %fail }
+
+{ the reason this compiles is that tdef.size and tabstractvarsym.getsize }
+{ both return an aint, and then the size of ta is reported as low(aint)  }
+
+type
+  ta = array[0..high(ptrint)] of byte;
+  tr = packed record
+    a: byte;
+    case byte of
+      0: (l: longint);
+      1: (e: ta);
+  end;
+
+begin
+  writeln(sizeof(ta));
+end.

tests/webtbf/tw9039b.pp

@@ -0,0 +1,17 @@
+{ %fail }
+
+{ the reason this compiles is that tdef.size and tabstractvarsym.getsize }
+{ both return an aint, and then the size of ta is reported as low(aint)  }
+
+type
+  ta = array[0..high(ptrint)] of byte;
+  tr = bitpacked record
+    a: byte;
+    case byte of
+      0: (l: longint);
+      1: (e: ta);
+  end;
+
+begin
+  writeln(sizeof(ta));
+end.

tests/webtbf/tw9039c.pp

@@ -0,0 +1,15 @@
+{ the reason this compiles is that tdef.size and tabstractvarsym.getsize }
+{ both return an aint, and then the size of ta is reported as low(aint)  }
+
+type
+  ta = array[1..high(ptrint)-4] of byte;
+  tr = packed record
+    l: longint;
+    case byte of
+      0: (l: longint);
+      1: (e: ta);
+  end;
+
+begin
+  writeln(sizeof(ta));
+end.

tests/webtbf/tw9039d.pp

@@ -0,0 +1,12 @@
+type
+  ta = array[1..high(ptrint) div 8-1] of byte;
+  tr = bitpacked record
+    a: byte;
+    case byte of
+      0: (l: longint);
+      1: (e: ta);
+  end;
+
+begin
+  writeln(sizeof(ta));
+end.