Merging -c 29493,29826,31916,32447,33176:33180,33190

git-svn-id: branches/fixes_3_0@33849 -

.gitattributes

@@ -663,7 +663,6 @@ compiler/symbase.pas svneol=native#text/plain
 compiler/symconst.pas svneol=native#text/plain
 compiler/symcreat.pas svneol=native#text/plain
 compiler/symdef.pas svneol=native#text/plain
-compiler/symnot.pas svneol=native#text/plain
 compiler/symsym.pas svneol=native#text/plain
 compiler/symtable.pas svneol=native#text/plain
 compiler/symtype.pas svneol=native#text/plain
@@ -14591,6 +14590,8 @@ tests/webtbs/tw2958.pp svneol=native#text/plain
 tests/webtbs/tw29609.pp svneol=native#text/pascal
 tests/webtbs/tw29620.pp svneol=native#text/plain
 tests/webtbs/tw2966.pp svneol=native#text/plain
+tests/webtbs/tw29669.pp svneol=native#text/plain
+tests/webtbs/tw29669a.pp svneol=native#text/plain
 tests/webtbs/tw29745.pp svneol=native#text/pascal
 tests/webtbs/tw2975.pp svneol=native#text/plain
 tests/webtbs/tw2976.pp svneol=native#text/plain

compiler/ncgmem.pas

@@ -320,6 +320,7 @@ implementation
         paraloc1 : tcgpara;
         tmpref: treference;
         sref: tsubsetreference;
+        awordoffset,
         offsetcorrection : aint;
         pd : tprocdef;
         sym : tsym;
@@ -446,14 +447,19 @@ implementation
                        offsetcorrection:=0;
                        if (left.location.size in [OS_PAIR,OS_SPAIR]) then
                          begin
-                           if (vs.fieldoffset>=sizeof(aword)) then
+                           if not is_packed_record_or_object(left.resultdef) then
-                             begin
+                             awordoffset:=sizeof(aword)
-                               location.sreg.subsetreg := left.location.registerhi;
+                           else
-                               offsetcorrection:=sizeof(aword)*8;
+                             awordoffset:=sizeof(aword)*8;
-                             end
+
+                           if (vs.fieldoffset>=awordoffset) xor (target_info.endian=endian_big) then
+                             location.sreg.subsetreg := left.location.registerhi
                            else
                              location.sreg.subsetreg := left.location.register;
 
+                           if vs.fieldoffset>=awordoffset then
+                             offsetcorrection := sizeof(aword)*8;
+
                            location.sreg.subsetregsize := OS_INT;
                          end
                        else

compiler/ncgnstld.pas

@@ -56,7 +56,6 @@ implementation
 
     uses
       cutils,verbose,globtype,globals,systems,constexp,
-      symnot,
       defutil,defcmp,
       htypechk,pass_1,procinfo,paramgr,
       cpuinfo,

compiler/nflw.pas

@@ -29,7 +29,6 @@ interface
     uses
       cclasses,
       node,cpubase,
-      symnot,
       symtype,symbase,symdef,symsym,
       optloop;
 
@@ -101,7 +100,6 @@ interface
           loopiteration : tnode;
           loopvar_notid:cardinal;
           constructor create(l,r,_t1,_t2 : tnode;back : boolean);virtual;reintroduce;
-          procedure loop_var_access(not_type:Tnotification_flag;symbol:Tsym);
           function wrap_to_value:tnode;
           function pass_typecheck:tnode;override;
           function pass_1 : tnode;override;
@@ -1432,26 +1430,6 @@ implementation
          include(loopflags,lnf_testatbegin);
       end;
 
-    procedure Tfornode.loop_var_access(not_type:Tnotification_flag;
-                                       symbol:Tsym);
-
-    begin
-      {If there is a read access, the value of the loop counter is important;
-       at the end of the loop the loop variable should contain the value it
-       had in the last iteration.}
-      if not_type=vn_onwrite then
-        begin
-          writeln('Loopvar does not matter on exit');
-        end
-      else
-        begin
-          exclude(loopflags,lnf_dont_mind_loopvar_on_exit);
-          writeln('Loopvar does matter on exit');
-        end;
-      Tabstractvarsym(symbol).unregister_notification(loopvar_notid);
-    end;
-
-
     function tfornode.simplify(forinline : boolean) : tnode;
       begin
         result:=nil;

compiler/nld.pas

@@ -174,7 +174,7 @@ implementation
 
     uses
       verbose,globtype,globals,systems,constexp,
-      symnot,symtable,
+      symtable,
       defutil,defcmp,
       htypechk,pass_1,procinfo,paramgr,
       cpuinfo,
@@ -425,10 +425,6 @@ implementation
                 { call to get address of threadvar }
                 if (vo_is_thread_var in tabstractvarsym(symtableentry).varoptions) then
                   include(current_procinfo.flags,pi_do_call);
-                if nf_write in flags then
-                  Tabstractvarsym(symtableentry).trigger_notifications(vn_onwrite)
-                else
-                  Tabstractvarsym(symtableentry).trigger_notifications(vn_onread);
               end;
             procsym :
                 begin

compiler/symdef.pas

@@ -281,6 +281,8 @@ interface
           function jvm_full_typename(with_package_name: boolean): string;
           { check if the symtable contains a float field }
           function contains_float_field : boolean;
+          { check if the symtable contains a field that spans an aword boundary }
+          function contains_cross_aword_field: boolean;
        end;
 
        pvariantrecdesc = ^tvariantrecdesc;
@@ -2059,13 +2061,14 @@ implementation
               recsize:=size;
               is_intregable:=
                 ispowerof2(recsize,temp) and
-                { sizeof(asizeint)*2 records in int registers is currently broken for endian_big targets }
+                ((recsize<=sizeof(aint)*2) and
-                (((recsize <= sizeof(asizeint)*2) and (target_info.endian=endian_little)
+                 not trecorddef(self).contains_cross_aword_field and
                  { records cannot go into registers on 16 bit targets for now }
-                  and (sizeof(asizeint)>2)
+                 (sizeof(aint)>2) and
-                  and not trecorddef(self).contains_float_field) or
+                 (not trecorddef(self).contains_float_field) or
-                  (recsize <= sizeof(asizeint)))
+                  (recsize <= sizeof(aint))
-                and not needs_inittable;
+                 ) and
+                 not needs_inittable;
             end;
         end;
      end;
@@ -4060,6 +4063,41 @@ implementation
       end;
 
 
+    function tabstractrecorddef.contains_cross_aword_field: boolean;
+      var
+        i : longint;
+        foffset, fsize: aword;
+      begin
+        result:=true;
+        for i:=0 to symtable.symlist.count-1 do
+          begin
+            if (tsym(symtable.symlist[i]).typ<>fieldvarsym) or
+               (sp_static in tsym(symtable.symlist[i]).symoptions) then
+              continue;
+            if assigned(tfieldvarsym(symtable.symlist[i]).vardef) then
+              begin
+                if is_packed then
+                  begin
+                    foffset:=tfieldvarsym(symtable.symlist[i]).fieldoffset;
+                    fsize:=tfieldvarsym(symtable.symlist[i]).vardef.packedbitsize;
+                  end
+                else
+                  begin
+                    foffset:=tfieldvarsym(symtable.symlist[i]).fieldoffset*8;
+                    fsize:=tfieldvarsym(symtable.symlist[i]).vardef.size*8;
+                  end;
+                if (foffset div (sizeof(aword)*8)) <> ((foffset+fsize-1) div (sizeof(aword)*8)) then
+                  exit;
+                { search recursively }
+                if (tstoreddef(tfieldvarsym(symtable.symlist[i]).vardef).typ=recorddef) and
+                  (tabstractrecorddef(tfieldvarsym(symtable.symlist[i]).vardef).contains_cross_aword_field) then
+                  exit;
+              end;
+          end;
+        result:=false;
+      end;
+
+
 {***************************************************************************
                                   trecorddef
 ***************************************************************************}

compiler/symnot.pas

@@ -1,63 +0,0 @@
-{
-    Copyright (c) 2002 by Daniel Mantione
-
-    This unit contains support routines for the variable access
-    notifier.
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-
-unit symnot;
-
-{$i fpcdefs.inc}
-
-interface
-
-uses  cclasses,symtype;
-
-type  Tnotification_flag=(vn_onread,vn_onwrite,vn_unknown);
-      Tnotification_flags=set of Tnotification_flag;
-
-      Tnotification_callback=procedure(not_type:Tnotification_flag;
-                                       symbol:Tsym) of object;
-
-      Tnotification=class(Tlinkedlistitem)
-        flags:Tnotification_flags;
-        callback:Tnotification_callback;
-        id:cardinal;
-        constructor create(Aflags:Tnotification_flags;
-                           Acallback:Tnotification_callback);
-      end;
-
-implementation
-
-var notification_counter:cardinal;
-
-constructor Tnotification.create(Aflags:Tnotification_flags;
-                                 Acallback:Tnotification_callback);
-
-begin
-  inherited create;
-  flags:=Aflags;
-  callback:=Acallback;
-  id:=notification_counter;
-  inc(notification_counter);
-end;
-
-begin
-  notification_counter:=0;
-end.

compiler/symsym.pas

@@ -33,7 +33,7 @@ interface
        symconst,symbase,symtype,symdef,defcmp,
        { ppu }
        ppu,finput,
-       cclasses,symnot,
+       cclasses,
        { aasm }
        aasmbase,
        cpuinfo,cpubase,cgbase,cgutils,parabase
@@ -168,7 +168,6 @@ interface
 
        tabstractvarsym = class(tstoredsym)
           varoptions    : tvaroptions;
-          notifications : Tlinkedlist;
           varspez       : tvarspez;  { sets the type of access }
           varregable    : tvarregable;
           varstate      : tvarstate;
@@ -179,24 +178,21 @@ interface
           addr_taken     : boolean;
           constructor create(st:tsymtyp;const n : string;vsp:tvarspez;def:tdef;vopts:tvaroptions);
           constructor ppuload(st:tsymtyp;ppufile:tcompilerppufile);
-          destructor  destroy;override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           procedure buildderef;override;
           procedure deref;override;
           function  getsize : asizeint;
           function  getpackedbitsize : longint;
           function  is_regvar(refpara: boolean):boolean;
-          procedure trigger_notifications(what:Tnotification_flag);
-          function register_notification(flags:Tnotification_flags;
-                                         callback:Tnotification_callback):cardinal;
-          procedure unregister_notification(id:cardinal);
         private
           _vardef     : tdef;
           vardefderef : tderef;
 
-          procedure setvardef(def:tdef);
+          procedure setregable;
+          procedure setvardef(const def: tdef);
+          procedure setvardef_and_regable(def:tdef);
         public
-          property vardef: tdef read _vardef write setvardef;
+          property vardef: tdef read _vardef write setvardef_and_regable;
       end;
 
       tfieldvarsym = class(tabstractvarsym)
@@ -1573,14 +1569,6 @@ implementation
       end;
 
 
-    destructor tabstractvarsym.destroy;
-      begin
-        if assigned(notifications) then
-          notifications.destroy;
-        inherited destroy;
-      end;
-
-
     procedure tabstractvarsym.buildderef;
       begin
         vardefderef.build(vardef);
@@ -1588,16 +1576,12 @@ implementation
 
 
     procedure tabstractvarsym.deref;
-      var
-        oldvarregable: tvarregable;
       begin
-        { setting the vardef also updates varregable. We just loaded this }
+        { assigning vardef also updates varregable. We just loaded this   }
         { value from a ppu, so it must not be changed (e.g. tw7817a.pp/   }
         { tw7817b.pp: the address is taken of a local variable in an      }
         { inlined procedure -> must remain non-regable when inlining)     }
-        oldvarregable:=varregable;
+        setvardef(tdef(vardefderef.resolve));
-        vardef:=tdef(vardefderef.resolve);
-        varregable:=oldvarregable;
       end;
 
 
@@ -1663,67 +1647,18 @@ implementation
       end;
 
 
-    procedure tabstractvarsym.trigger_notifications(what:Tnotification_flag);
+    procedure tabstractvarsym.setvardef_and_regable(def:tdef);
-
+      begin
-    var n:Tnotification;
+        setvardef(def);
-
+         setregable;
-    begin
+      end;
-        if assigned(notifications) then
+
-          begin
+
-            n:=Tnotification(notifications.first);
+    procedure tabstractvarsym.setregable;
-            while assigned(n) do
-              begin
-                if what in n.flags then
-                  n.callback(what,self);
-                n:=Tnotification(n.next);
-              end;
-          end;
-    end;
-
-    function Tabstractvarsym.register_notification(flags:Tnotification_flags;callback:
-                                           Tnotification_callback):cardinal;
-
-    var n:Tnotification;
-
-    begin
-      if not assigned(notifications) then
-        notifications:=Tlinkedlist.create;
-      n:=Tnotification.create(flags,callback);
-      register_notification:=n.id;
-      notifications.concat(n);
-    end;
-
-    procedure Tabstractvarsym.unregister_notification(id:cardinal);
-
-    var n:Tnotification;
-
-    begin
-      if not assigned(notifications) then
-        internalerror(200212311)
-      else
-        begin
-            n:=Tnotification(notifications.first);
-            while assigned(n) do
-              begin
-                if n.id=id then
-                  begin
-                    notifications.remove(n);
-                    n.destroy;
-                    exit;
-                  end;
-                n:=Tnotification(n.next);
-              end;
-            internalerror(200212311)
-        end;
-    end;
-
-
-    procedure tabstractvarsym.setvardef(def:tdef);
       begin
-        _vardef := def;
          { can we load the value into a register ? }
         if not assigned(owner) or
-           (owner.symtabletype in [localsymtable,parasymtable]) or
+           (owner.symtabletype in [localsymtable, parasymtable]) or
            (
             (owner.symtabletype=staticsymtable) and
             not(cs_create_pic in current_settings.moduleswitches)
@@ -1746,23 +1681,23 @@ implementation
                 (typ=paravarsym) and
                 (varspez=vs_const)) then
               varregable:=vr_intreg
-            else
+            else if tstoreddef(vardef).is_fpuregable then
-{ $warning TODO: no fpu regvar in staticsymtable yet, need initialization with 0 }
+              begin
-              if {(
+                if use_vectorfpu(vardef) then
-                  not assigned(owner) or
+                  varregable:=vr_mmreg
-                  (owner.symtabletype<>staticsymtable)
+                else
-                 ) and }
+                  varregable:=vr_fpureg;
-                 tstoreddef(vardef).is_fpuregable then
+              end;
-                 begin
-                   if use_vectorfpu(vardef) then
-                     varregable:=vr_mmreg
-                   else
-                     varregable:=vr_fpureg;
-                 end;
           end;
       end;
 
 
+    procedure tabstractvarsym.setvardef(const def: tdef);
+      begin
+        _vardef := def;
+      end;
+
+
 {****************************************************************************
                                TFIELDVARSYM
 ****************************************************************************}

tests/webtbs/tw29669.pp

@@ -0,0 +1,52 @@
+{$mode objfpc}
+
+program Project1;
+
+uses
+ SysUtils;
+
+type
+  TPackedIdLevel1 = 0..255;
+  TPackedIdLevel2 = 0..65535;
+  TPackedIdLevel3 = 0..65535;
+  TPackedIdLevel4 = 0..65535;
+  TPackedIdLevel5 = 0..255;
+
+  TPackedId = bitpacked record
+    clusterId : TPackedIdLevel5;
+    agentId : TPackedIdLevel4;
+    dataSourceId : TPackedIdLevel3;
+    deviceId : TPackedIdLevel2;
+    esmId : TPackedIdLevel1;
+  end;
+
+function PackedIdToStr(const ipsid : qword) : string;
+begin
+  result := IntToStr(TPackedId(ipsid).esmId) + '-' +
+            IntToStr(TPackedId(ipsid).deviceId) + '-' +
+            IntToStr(TPackedId(ipsid).dataSourceId) + '-' +
+            IntToStr(TPackedId(ipsid).agentId) + '-' +
+            IntToStr(TPackedId(ipsid).clusterId);
+  if TPackedId(ipsid).clusterid<>123 then
+    halt(1);
+  if TPackedId(ipsid).agentid<>45678 then
+    halt(2);
+  if TPackedId(ipsid).datasourceid<>9012 then
+    halt(3);
+  if TPackedId(ipsid).deviceid<>34567 then
+    halt(4);
+  if TPackedId(ipsid).esmid<>89 then
+    halt(5);
+
+end;
+
+var
+  pi: TPackedId;
+begin
+  pi.clusterid:=123;
+  pi.agentid:=45678;
+  pi.datasourceid:=9012;
+  pi.deviceid:=34567;
+  pi.esmid:=89;
+  writeln(PackedIdToStr(qword(pi)));
+end.

tests/webtbs/tw29669a.pp

@@ -0,0 +1,52 @@
+{$mode objfpc}
+
+program Project1;
+
+uses
+ SysUtils;
+
+type
+  TPackedIdLevel1 = 0..255;
+  TPackedIdLevel2 = 0..65535;
+  TPackedIdLevel3 = 0..65535;
+  TPackedIdLevel4 = 0..65535;
+  TPackedIdLevel5 = 0..255;
+
+  TPackedId = bitpacked record
+    clusterId : TPackedIdLevel5;
+    esmId : TPackedIdLevel1;
+    agentId : TPackedIdLevel4;
+    dataSourceId : TPackedIdLevel3;
+    deviceId : TPackedIdLevel2;
+  end;
+
+function PackedIdToStr(const ipsid : qword) : string;
+begin
+  result := IntToStr(TPackedId(ipsid).esmId) + '-' +
+            IntToStr(TPackedId(ipsid).deviceId) + '-' +
+            IntToStr(TPackedId(ipsid).dataSourceId) + '-' +
+            IntToStr(TPackedId(ipsid).agentId) + '-' +
+            IntToStr(TPackedId(ipsid).clusterId);
+  if TPackedId(ipsid).clusterid<>123 then
+    halt(1);
+  if TPackedId(ipsid).agentid<>45678 then
+    halt(2);
+  if TPackedId(ipsid).datasourceid<>9012 then
+    halt(3);
+  if TPackedId(ipsid).deviceid<>34567 then
+    halt(4);
+  if TPackedId(ipsid).esmid<>89 then
+    halt(5);
+
+end;
+
+var
+  pi: TPackedId;
+begin
+  pi.clusterid:=123;
+  pi.agentid:=45678;
+  pi.datasourceid:=9012;
+  pi.deviceid:=34567;
+  pi.esmid:=89;
+  writeln(PackedIdToStr(qword(pi)));
+end.