--- Merging r18162 into '.':

A    tests/tbs/tb0577.pp
U    compiler/pexpr.pas
U    compiler/htypechk.pas
U    compiler/ncal.pas
--- Merging r18173 into '.':
A    tests/tbs/tb0577a.pp
G    compiler/htypechk.pas
--- Merging r18254 into '.':
U    compiler/ncgadd.pas
--- Merging r18265 into '.':
U    compiler/globals.pas
U    compiler/scanner.pas
--- Merging r19199 into '.':
A    tests/webtbf/tw20095.pp
G    compiler/htypechk.pas
--- Merging r19490 into '.':
U    rtl/inc/strings.pp
--- Merging r19492 into '.':
A    tests/tbf/tb0222.pp
U    compiler/pdecsub.pas
U    compiler/symsym.pas
--- Merging r19494 into '.':
U    tests/tbf/tb0222.pp
--- Merging r19524 into '.':
A    tests/webtbs/tw20527.pp
U    compiler/ptype.pas
--- Merging r19610 into '.':
U    tests/test/packages/cocoaint/tobjcnh1.pp
U    tests/test/packages/cocoaint/tvarpara.pp

git-svn-id: branches/fixes_2_6@20426 -

.gitattributes

@@ -8620,6 +8620,7 @@ tests/tbf/tb0218.pp svneol=native#text/plain
 tests/tbf/tb0219.pp svneol=native#text/pascal
 tests/tbf/tb0220.pp svneol=native#text/plain
 tests/tbf/tb0221.pp svneol=native#text/plain
+tests/tbf/tb0222.pp svneol=native#text/plain
 tests/tbf/ub0115.pp svneol=native#text/plain
 tests/tbf/ub0149.pp svneol=native#text/plain
 tests/tbf/ub0158a.pp svneol=native#text/plain
@@ -9193,6 +9194,8 @@ tests/tbs/tb0573.pp svneol=native#text/plain
 tests/tbs/tb0574.pp svneol=native#text/pascal
 tests/tbs/tb0575.pp svneol=native#text/plain
 tests/tbs/tb0576.pp svneol=native#text/plain
+tests/tbs/tb0577.pp svneol=native#text/plain
+tests/tbs/tb0577a.pp svneol=native#text/plain
 tests/tbs/tb205.pp svneol=native#text/plain
 tests/tbs/ub0060.pp svneol=native#text/plain
 tests/tbs/ub0069.pp svneol=native#text/plain
@@ -10944,6 +10947,7 @@ tests/webtbf/tw19591.pp svneol=native#text/plain
 tests/webtbf/tw1969.pp svneol=native#text/plain
 tests/webtbf/tw1995.pp svneol=native#text/plain
 tests/webtbf/tw19975.pp svneol=native#text/pascal
+tests/webtbf/tw20095.pp svneol=native#text/plain
 tests/webtbf/tw2018.pp svneol=native#text/plain
 tests/webtbf/tw2037.pp svneol=native#text/plain
 tests/webtbf/tw2046.pp svneol=native#text/plain
@@ -11815,6 +11819,7 @@ tests/webtbs/tw2040.pp svneol=native#text/plain
 tests/webtbs/tw2041.pp svneol=native#text/plain
 tests/webtbs/tw2045.pp svneol=native#text/plain
 tests/webtbs/tw2046a.pp svneol=native#text/plain
+tests/webtbs/tw20527.pp svneol=native#text/plain
 tests/webtbs/tw2059.pp svneol=native#text/plain
 tests/webtbs/tw20594.pp svneol=native#text/pascal
 tests/webtbs/tw20638.pp svneol=native#text/pascal

compiler/globals.pas

@@ -68,7 +68,7 @@ interface
          [m_gpc,m_all,m_tp_procvar];
 {$endif}
        macmodeswitches =
-         [m_mac,m_all,m_cvar_support,m_mac_procvar,m_nested_procvars,m_non_local_goto,m_isolike_unary_minus];
+         [m_mac,m_all,m_cvar_support,m_mac_procvar,m_nested_procvars,m_non_local_goto,m_isolike_unary_minus,m_default_inline];
        isomodeswitches =
          [m_iso,m_all,m_tp_procvar,m_duplicate_names,m_nested_procvars,m_non_local_goto,m_isolike_unary_minus];
 

compiler/htypechk.pas

@@ -67,12 +67,12 @@ interface
         FParaNode   : tnode;
         FParaLength : smallint;
         FAllowVariant : boolean;
-        procedure collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers:boolean);
+        procedure collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers,anoninherited:boolean);
         procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall,explicitunit: boolean);
-        procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers:boolean);
+        procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean);
         function  proc_add(st:tsymtable;pd:tprocdef;objcidcall: boolean):pcandidate;
       public
-        constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers:boolean);
+        constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean);
         constructor create_operator(op:ttoken;ppn:tnode);
         destructor destroy;override;
         procedure list(all:boolean);
@@ -1156,14 +1156,11 @@ implementation
                else
                  begin
                    { 1. if it returns a pointer and we've found a deref,
-                     2. if it returns a class or record and a subscription or with is found
+                     2. if it returns a class and a subscription or with is found
                      3. if the address is needed of a field (subscriptn, vecn) }
                    if (gotpointer and gotderef) or
                       (gotstring and gotvec) or
-                      (
-                       (gotclass or gotrecord) and
-                       (gotsubscript)
-                      ) or
+                      (gotclass and gotsubscript) or
                       (
                         (gotvec and gotdynarray)
                       ) or
@@ -1758,7 +1755,7 @@ implementation
                            TCallCandidates
 ****************************************************************************}
 
-    constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers:boolean);
+    constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean);
       begin
         if not assigned(sym) then
           internalerror(200411015);
@@ -1766,7 +1763,7 @@ implementation
         FProcsym:=sym;
         FProcsymtable:=st;
         FParanode:=ppn;
-        create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers);
+        create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited);
       end;
 
 
@@ -1776,7 +1773,7 @@ implementation
         FProcsym:=nil;
         FProcsymtable:=nil;
         FParanode:=ppn;
-        create_candidate_list(false,false,false,false,false);
+        create_candidate_list(false,false,false,false,false,false);
       end;
 
 
@@ -1795,21 +1792,43 @@ implementation
       end;
 
 
-    procedure tcallcandidates.collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers:boolean);
+    procedure tcallcandidates.collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers,anoninherited:boolean);
 
-      function processprocsym(srsym:tprocsym):boolean;
+      function processprocsym(srsym:tprocsym; out foundanything: boolean):boolean;
         var
           j  : integer;
           pd : tprocdef;
         begin
-          { Store first procsym found }
-          if not assigned(FProcsym) then
-            FProcsym:=srsym;
           { add all definitions }
           result:=false;
+          foundanything:=false;
           for j:=0 to srsym.ProcdefList.Count-1 do
             begin
               pd:=tprocdef(srsym.ProcdefList[j]);
+              { in case of anonymous inherited, only match procdefs identical
+                to the current one (apart from hidden parameters), rather than
+                anything compatible to the parameters -- except in case of
+                the presence of a messagestr/int, in which case those have to
+                match exactly }
+              if anoninherited then
+                if po_msgint in current_procinfo.procdef.procoptions then
+                  begin
+                    if not(po_msgint in pd.procoptions) or
+                       (pd.messageinf.i<>current_procinfo.procdef.messageinf.i) then
+                      continue
+                  end
+                else if po_msgstr in current_procinfo.procdef.procoptions then
+                  begin
+                    if not(po_msgstr in pd.procoptions) or
+                       (pd.messageinf.str^<>current_procinfo.procdef.messageinf.str^) then
+                      continue
+                  end
+                else if (compare_paras(current_procinfo.procdef.paras,pd.paras,cp_all,[cpo_ignorehidden])<te_equal) then
+                  continue;
+              foundanything:=true;
+              { Store first procsym found }
+              if not assigned(FProcsym) then
+                FProcsym:=tprocsym(srsym);
               if po_overload in pd.procoptions then
                 result:=true;
               ProcdefOverloadList.Add(srsym.ProcdefList[j]);
@@ -1819,7 +1838,8 @@ implementation
       var
         srsym      : tsym;
         hashedid   : THashedIDString;
-        hasoverload : boolean;
+        hasoverload,
+        foundanything : boolean;
         helperdef  : tobjectdef;
       begin
         if FOperator=NOTOKEN then
@@ -1843,9 +1863,10 @@ implementation
                            { Delphi allows hiding a property by a procedure with the same name }
                            (srsym.typ=procsym) then
                          begin
-                           hasoverload := processprocsym(tprocsym(srsym));
+                           hasoverload:=processprocsym(tprocsym(srsym),foundanything);
                            { when there is no explicit overload we stop searching }
-                           if not hasoverload then
+                           if foundanything and
+                              not hasoverload then
                              break;
                          end;
                        helperdef:=helperdef.childof;
@@ -1860,9 +1881,10 @@ implementation
               { Delphi allows hiding a property by a procedure with the same name }
               (srsym.typ=procsym) then
              begin
-               hasoverload:=processprocsym(tprocsym(srsym));
+               hasoverload:=processprocsym(tprocsym(srsym),foundanything);
                { when there is no explicit overload we stop searching }
-               if not hasoverload then
+               if foundanything and
+                  not hasoverload then
                  break;
              end;
            if is_objectpascal_helper(structdef) and
@@ -1874,9 +1896,10 @@ implementation
                   { Delphi allows hiding a property by a procedure with the same name }
                   (srsym.typ=procsym) then
                  begin
-                   hasoverload:=processprocsym(tprocsym(srsym));
+                   hasoverload:=processprocsym(tprocsym(srsym),foundanything);
                    { when there is no explicit overload we stop searching }
-                   if not hasoverload then
+                   if foundanything and
+                      not hasoverload then
                      break;
                  end;
              end;
@@ -1960,7 +1983,7 @@ implementation
       end;
 
 
-    procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers:boolean);
+    procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean);
       var
         j     : integer;
         pd    : tprocdef;
@@ -1978,7 +2001,7 @@ implementation
         if not objcidcall and
            (FOperator=NOTOKEN) and
            (FProcsym.owner.symtabletype in [objectsymtable,recordsymtable]) then
-          collect_overloads_in_struct(tabstractrecorddef(FProcsym.owner.defowner),ProcdefOverloadList,searchhelpers)
+          collect_overloads_in_struct(tabstractrecorddef(FProcsym.owner.defowner),ProcdefOverloadList,searchhelpers,anoninherited)
         else
         if (FOperator<>NOTOKEN) then
           begin
@@ -1988,7 +2011,7 @@ implementation
             while assigned(pt) do
               begin
                 if (pt.resultdef.typ=recorddef) then
-                  collect_overloads_in_struct(tabstractrecorddef(pt.resultdef),ProcdefOverloadList,searchhelpers);
+                  collect_overloads_in_struct(tabstractrecorddef(pt.resultdef),ProcdefOverloadList,searchhelpers,anoninherited);
                 pt:=tcallparanode(pt.right);
               end;
             collect_overloads_in_units(ProcdefOverloadList,objcidcall,explicitunit);

compiler/ncal.pas

@@ -2739,7 +2739,7 @@ implementation
                                     ((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags));
                   candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility,
                     not(nf_isproperty in flags),cnf_objc_id_call in callnodeflags,cnf_unit_specified in callnodeflags,
-                    callnodeflags*[cnf_anon_inherited,cnf_inherited]=[]);
+                    callnodeflags*[cnf_anon_inherited,cnf_inherited]=[],cnf_anon_inherited in callnodeflags);
 
                    { no procedures found? then there is something wrong
                      with the parameter size or the procedures are

compiler/ncgadd.pas

@@ -349,14 +349,14 @@ interface
       begin
         if nodetype<>addn then
           internalerror(20080302);
-        { setelementn is a special case, it must be on right }
-        if (nf_swapped in flags) and
-           (left.nodetype=setelementn) then
-          swapleftright;
         { no range support for smallsets }
         if assigned(tsetelementnode(right).right) then
           internalerror(20080303);
         pass_left_right;
+        { setelementn is a special case, it must be on right }
+        if (nf_swapped in flags) and
+           (left.nodetype=setelementn) then
+          swapleftright;
         force_reg_left_right(false,false);
         set_result_location_reg;
         setbase:=tsetdef(left.resultdef).setbase;

compiler/pdecsub.pas

@@ -3204,7 +3204,12 @@ const
                      po_comp:=[po_classmethod,po_methodpointer];
 
                    if ((po_comp * fwpd.procoptions)<>(po_comp * currpd.procoptions)) or
-                      (fwpd.proctypeoption <> currpd.proctypeoption) then
+                      (fwpd.proctypeoption <> currpd.proctypeoption) or
+                      { if the implementation version has an "overload" modifier,
+                        the interface version must also have it (otherwise we can
+                        get annoying crashes due to interface crc changes) }
+                      (not(po_overload in fwpd.procoptions) and
+                       (po_overload in currpd.procoptions)) then
                      begin
                        MessagePos1(currpd.fileinfo,parser_e_header_dont_match_forward,
                                    fwpd.fullprocname(false));
@@ -3344,7 +3349,7 @@ const
                   begin
                     MessagePos1(currpd.fileinfo,parser_e_no_overload_for_all_procs,currpd.procsym.realname);
                     break;
-                  end;
+                  end
                end
               else
                begin

compiler/pexpr.pas

@@ -2321,6 +2321,7 @@ implementation
          hs,hsorg   : string;
          hdef       : tdef;
          filepos    : tfileposinfo;
+         callflags  : tcallnodeflags;
          again,
          updatefpos,
          nodechanged  : boolean;
@@ -2467,7 +2468,10 @@ implementation
                              p1:=cerrornode.create;
                            end;
                        end;
-                       do_member_read(hclassdef,getaddr,srsym,p1,again,[cnf_inherited,cnf_anon_inherited]);
+                       callflags:=[cnf_inherited];
+                       if anon_inherited then
+                         include(callflags,cnf_anon_inherited);
+                       do_member_read(hclassdef,getaddr,srsym,p1,again,callflags);
                      end
                     else
                      begin

compiler/ptype.pas

@@ -570,7 +570,7 @@ implementation
                          if not(stoAllowTypeDef in options) then
                            Message(parser_e_no_local_para_def);
                          consume(_OF);
-                         single_type(t2,[]);
+                         single_type(t2,[stoAllowTypeDef]);
                          if is_managed_type(t2) then
                            Message(parser_e_no_refcounted_typed_file);
                          def:=tfiledef.createtyped(t2);

compiler/scanner.pas

@@ -309,9 +309,9 @@ implementation
          end
         else
          begin
-           exclude(current_settings.localswitches,cs_ansistrings);
+           exclude(current_settings.localswitches,cs_do_inline);
            if changeinit then
-            exclude(init_settings.localswitches,cs_ansistrings);
+            exclude(init_settings.localswitches,cs_do_inline);
          end;
       end;
 

compiler/symsym.pas

@@ -381,14 +381,26 @@ implementation
 
 
     procedure tstoredsym.ppuwrite(ppufile:tcompilerppufile);
+      var
+        oldintfcrc : boolean;
       begin
          ppufile.putlongint(SymId);
          ppufile.putstring(realname);
          ppufile.putposinfo(fileinfo);
          ppufile.putbyte(byte(visibility));
+         { symoptions can differ between interface and implementation, except
+           for overload (this is checked in pdecsub.proc_add_definition() )
+
+           These differences can lead to compiler crashes, so ignore them.
+           This does mean that changing e.g. the "deprecated" state of a symbol
+           by itself will not trigger a recompilation of dependent units.
+         }
+         oldintfcrc:=ppufile.do_interface_crc;
+         ppufile.do_interface_crc:=false;
          ppufile.putsmallset(symoptions);
          if sp_has_deprecated_msg in symoptions then
            ppufile.putstring(deprecatedmsg^);
+         ppufile.do_interface_crc:=oldintfcrc;
       end;
 
 

rtl/inc/strings.pp

@@ -26,11 +26,11 @@ interface
     function strpcopy(d : pchar;const s : string) : pchar;
 
     { Copies source to dest, returns a pointer to dest }
-    function strcopy(dest,source : pchar) : pchar;
+    function strcopy(dest,source : pchar) : pchar; overload;
 
     { Copies at most maxlen bytes from source to dest. }
     { Returns a pointer to dest }
-    function strlcopy(dest,source : pchar;maxlen : SizeInt) : pchar;
+    function strlcopy(dest,source : pchar;maxlen : SizeInt) : pchar; overload;
 
     { Copies source to dest and returns a pointer to the terminating }
     { null character.    }

tests/tbf/tb0222.pp

@@ -0,0 +1,16 @@
+{ %fail }
+unit tb0222;
+
+{$mode delphi}
+
+interface
+
+procedure test;
+
+implementation
+
+procedure test; overload;
+begin
+end;
+
+end.

tests/tbs/tb0577.pp

@@ -0,0 +1,51 @@
+program tb0577;
+
+{$mode delphi}
+
+type
+  tc = class
+    procedure test(b: byte);virtual;overload;
+  end;
+
+  tc2 = class(tc)
+   strict protected
+    procedure test(b: byte; l: longint = 1234);virtual;overload;
+   public
+    procedure test(l: longint);virtual;overload;
+  end;
+
+  tc3 = class(tc2)
+    procedure test(b: byte);override;overload;
+  end;
+
+var
+  glob: longint;
+
+  procedure tc.test(b: byte);
+    begin
+      glob:=2;
+    end;
+
+  procedure tc2.test(l: longint);
+    begin
+      glob:=1;
+    end;
+
+  procedure tc2.test(b: byte; l: longint = 1234);
+    begin
+      glob:=3;
+    end;
+
+  procedure tc3.test(b: byte);
+    begin
+      inherited;
+    end;
+
+var
+  c: tc;
+begin
+  c:=tc3.create;
+  c.test(byte(4));
+  if glob<>2 then
+    halt(1);
+end.

tests/tbs/tb0577a.pp

@@ -0,0 +1,63 @@
+{$mode delphi}
+
+const
+  cdefaulthandler = 1;
+  cinheritedhandler = 2;
+  cunsupportedhandler = 3;
+
+type
+  tc = class
+    procedure defaulthandler(var message); override;
+    procedure handler(var message:longint); message cinheritedhandler;
+  end;
+
+  tc2 = class(tc)
+    procedure handler(var message: longint);
+  end;
+
+  tc3 = class(tc2)
+    procedure someproc(var message:tc3); message cinheritedhandler;
+    procedure handler(var message:tc3); message cunsupportedhandler;
+  end;
+
+var
+  glob: longint;
+
+procedure tc.defaulthandler(var message);
+begin
+  glob:=cdefaulthandler;
+end;
+
+procedure tc.handler(var message: longint);
+begin
+  glob:=cinheritedhandler;
+end;
+
+
+procedure tc2.handler(var message: longint);
+begin
+  halt(1);
+end;
+
+procedure tc3.someproc(var message: tc3);
+begin
+  inherited;
+end;
+
+procedure tc3.handler(var message: tc3);
+begin
+  glob:=cunsupportedhandler;
+  inherited
+end;
+
+var
+  c: tc3;
+begin
+  c:=tc3.create;
+  c.someproc(c);
+  if glob<>cinheritedhandler then
+    halt(2);
+  c.handler(c);
+  if glob<>cdefaulthandler then
+    halt(3);
+end.

tests/test/packages/cocoaint/tobjcnh1.pp

@@ -1,5 +1,5 @@
 { %target=darwin }
-{ %cpu=powerpc,i386 }
+{ %cpu=powerpc,i386,powerpc64,x86_64 }
 
 {$mode objfpc}{$H+}
 {$modeswitch objectivec1}

tests/test/packages/cocoaint/tvarpara.pp

@@ -1,5 +1,5 @@
 { %target=darwin }
-{ %cpu=powerpc,i386 }
+{ %cpu=powerpc,i386,powerpc64,x86_64 }
 
 {$mode objfpc}{$H+}
 {$modeswitch objectivec1}

tests/webtbf/tw20095.pp

@@ -0,0 +1,103 @@
+{ %fail }
+
+program project1;
+
+{$mode objfpc}{$H+}
+
+uses
+  sysutils, Classes;
+
+type
+
+generic TBroken<_T> = class
+  private type
+    T_TArray = array of _T;
+  private var
+    FArray: T_TArray;
+  private
+    function FGetTopEntry(): _T;
+    procedure FSetTopEntry(Value: _T);
+  public
+    constructor Create(Len: integer);
+
+    property TopEntry: _T read FGetTopEntry write FSetTopEntry;
+end;
+
+TRecord = record
+  x, y, z: integer;
+end;
+
+TMaybeBroken = class
+  private
+    FArray: array of TRecord;
+
+    function FGetTopEntry(): TRecord;
+    procedure FSetTopEntry(Value: TRecord);
+  public
+    constructor Create(Len: integer);
+
+    property TopEntry: TRecord read FGetTopEntry write FSetTopEntry;
+end;
+
+
+TBrokenRecord = specialize TBroken<TRecord>; // pun intended
+
+var
+  a: TBrokenRecord;
+  b: TMaybeBroken;
+  i: integer;
+
+constructor TBroken.Create(Len: integer);
+  var
+    i: integer;
+  begin
+    SetLength(FArray, Len);
+    FillChar(FArray[0], SizeOf(_T) * Len, 0);
+end;
+
+function TBroken.FGetTopEntry(): _T;
+  begin
+    Result := FArray[High(FArray)];
+end;
+
+procedure TBroken.FSetTopEntry(Value: _T);
+  begin
+    FArray[High(FArray)] := Value;
+end;
+
+constructor TMaybeBroken.Create(Len: integer);
+  var
+    i: integer;
+  begin
+    SetLength(FArray, Len);
+    FillChar(FArray[0], SizeOf(TRecord) * Len, 0);
+end;
+
+function TMaybeBroken.FGetTopEntry(): TRecord;
+  begin
+    Result := FArray[High(FArray)];
+end;
+
+procedure TMaybeBroken.FSetTopEntry(Value: TRecord);
+  begin
+    FArray[High(FArray)] := Value;
+end;
+
+begin
+  a := TBrokenRecord.Create(10);
+  Inc(a.TopEntry.x);
+
+  for i := 0 to 9 do writeln(inttostr(a.FArray[i].x));
+
+  a.Free();
+
+  writeln('---');
+
+  b := TMaybeBroken.Create(10);
+  Inc(b.TopEntry.x);
+
+  for i := 0 to 9 do writeln(inttostr(b.FArray[i].x));
+
+  b.Free();
+
+end.

tests/webtbs/tw20527.pp

@@ -0,0 +1,10 @@
+{ %norun }
+
+type
+  s = string[10];
+Var
+  fos: file of s;
+  aos: array[char]of string[63];
+  fosx: File of String[63]; (* become bad *)
+Begin
+end.