Merged revisions 13599-13600,13602-13604,13608,13615-13618 via svnmerge from

svn+ssh://jonas@svn.freepascal.org/FPC/svn/fpc/trunk

git-svn-id: branches/objc@13621 -

.gitattributes

@@ -8647,6 +8647,12 @@ tests/webtbf/tw1365.pp svneol=native#text/plain
 tests/webtbf/tw13815.pp svneol=native#text/plain
 tests/webtbf/tw1395.pp svneol=native#text/plain
 tests/webtbf/tw13956.pp svneol=native#text/plain
+tests/webtbf/tw13971a.pp svneol=native#text/plain
+tests/webtbf/tw13971b.pp svneol=native#text/plain
+tests/webtbf/tw13971c.pp svneol=native#text/plain
+tests/webtbf/tw13971d.pp svneol=native#text/plain
+tests/webtbf/tw13971e.pp svneol=native#text/plain
+tests/webtbf/tw13971f.pp svneol=native#text/plain
 tests/webtbf/tw13992.pp svneol=native#text/plain
 tests/webtbf/tw1407.pp svneol=native#text/plain
 tests/webtbf/tw14104a.pp svneol=native#text/plain
@@ -9245,6 +9251,7 @@ tests/webtbs/tw14307.pp svneol=native#text/plain
 tests/webtbs/tw1433.pp svneol=native#text/plain
 tests/webtbs/tw14363.pp svneol=native#text/plain
 tests/webtbs/tw14403.pp svneol=native#text/plain
+tests/webtbs/tw14418.pp svneol=native#text/plain
 tests/webtbs/tw1445.pp svneol=native#text/plain
 tests/webtbs/tw1450.pp svneol=native#text/plain
 tests/webtbs/tw1451.pp svneol=native#text/plain

compiler/nobj.pas

@@ -612,8 +612,8 @@ implementation
         for i:=0 to _class.ImplementedInterfaces.count-1 do
           begin
             ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
-            { if it implements itself }
-            if ImplIntf.VtblImplIntf=ImplIntf then
+            { if it implements itself and if it's not implemented by delegation }
+            if (ImplIntf.VtblImplIntf=ImplIntf) and (ImplIntf.IType=etStandard) then
               begin
                 { allocate a pointer in the object memory }
                 with tObjectSymtable(_class.symtable) do
@@ -630,7 +630,7 @@ implementation
           begin
             ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]);
             if ImplIntf.VtblImplIntf<>ImplIntf then
-              ImplIntf.Ioffset:=ImplIntf.VtblImplIntf.Ioffset;
+              ImplIntf.IOffset:=ImplIntf.VtblImplIntf.IOffset;
           end;
       end;
 
@@ -1211,9 +1211,9 @@ implementation
         current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(intf_get_vtbl_name(AImplIntf.VtblImplIntf),0));
         { IOffset field }
         case AImplIntf.VtblImplIntf.IType of
+          etFieldValue,
           etStandard:
             current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(AImplIntf.VtblImplIntf.IOffset));
-          etFieldValue,
           etVirtualMethodResult,
           etStaticMethodResult:
             current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(0));

compiler/pdecsub.pas

@@ -309,8 +309,12 @@ implementation
                begin
                  if is_open_string(vardef) then
                     MessagePos(fileinfo,parser_w_cdecl_no_openstring);
-                 if not (po_external in pd.procoptions) then
-                   MessagePos(fileinfo,parser_w_cdecl_has_no_high);
+                 if not(po_external in pd.procoptions) and
+                    (pd.typ<>procvardef) then
+                   if is_array_of_const(vardef) then
+                     MessagePos(fileinfo,parser_e_varargs_need_cdecl_and_external)
+                   else
+                     MessagePos(fileinfo,parser_w_cdecl_has_no_high);
                end;
               if (vardef.typ=formaldef) and (Tformaldef(vardef).typed) then
                 begin

compiler/pdecvar.pas

@@ -740,6 +740,7 @@ implementation
              if found then
                begin
                  ImplIntf.ImplementsGetter:=p;
+                 ImplIntf.VtblImplIntf:=ImplIntf;
                  case p.propaccesslist[palt_read].firstsym^.sym.typ of
                    procsym :
                      begin
@@ -749,7 +750,11 @@ implementation
                          ImplIntf.IType:=etStaticMethodResult;
                      end;
                    fieldvarsym :
-                     ImplIntf.IType:=etFieldValue;
+                     begin
+                       ImplIntf.IType:=etFieldValue;
+                       { this must be done more sophisticated, here is also probably the wrong place }
+                       ImplIntf.IOffset:=tfieldvarsym(p.propaccesslist[palt_read].firstsym^.sym).fieldoffset;
+                     end
                    else
                      internalerror(200802161);
                  end;

compiler/symdef.pas

@@ -2094,7 +2094,7 @@ implementation
       begin
          result:=true;
       end;
-      
+
 
     procedure tclassrefdef.reset;
       begin
@@ -4502,7 +4502,7 @@ implementation
       begin
         result:=false;
         { interfaces being implemented through delegation are not mergable (FK) }
-        if (MergingIntf.IType<>etStandard) or not(assigned(ProcDefs)) then
+        if (IType<>etStandard) or (MergingIntf.IType<>etStandard) or not(assigned(ProcDefs)) then
           exit;
         weight:=0;
         { empty interface is mergeable }

compiler/systems/t_bsd.pas

@@ -152,7 +152,19 @@ begin
            end
          else
            begin
+{$ifndef cpu64bitaddr}
+             { Set the size of the page at address zero to 64kb, so nothing
+               is loaded below that address. This avoids problems with the
+               strange Windows-compatible resource handling that assumes
+               that addresses below 64kb do not exist.
+               
+               On 64bit systems, page zero is 4GB by default, so no problems
+               there.
+             }
+             ExeCmd[1]:='ld $PRTOBJ $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP -pagezero_size 0x10000 -no_dead_strip_inits_and_terms -multiply_defined suppress -L. -o $EXE `cat $RES`';
+{$else ndef cpu64bitaddr}
              ExeCmd[1]:='ld $PRTOBJ $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP -no_dead_strip_inits_and_terms -multiply_defined suppress -L. -o $EXE `cat $RES`';
+{$endif ndef cpu64bitaddr}
              if (apptype<>app_bundle) then
                DllCmd[1]:='libtool $PRTOBJ $OPT -no_dead_strip_inits_and_terms -dynamic -multiply_defined suppress -L. -o $EXE `cat $RES`'
              else

ide/wchmhwrap.pas

@@ -76,7 +76,7 @@ end;
 Constructor TChmWrapper.Create(name:string);
 
 begin
-  ffs:=Classes.TFileStream.create(name,fmOpenRead);
+  ffs:=Classes.TFileStream.create(name,fmOpenRead or fmsharedenynone);
   fchmr:=TChmReader.Create(ffs,True); // owns ffs
   findex:=nil;
   if not fchmr.isvalidfile then
@@ -235,8 +235,10 @@ begin
   freeandnil(ftopic);
   freeandnil(findex);
   freeandnil(fchmr);
+  {$ifdef wdebug}
+    debugmessageS({$i %file%},'TCHMWrapper: destroying ',{$i %line%},'1',0,0);
+  {$endif}
+
 end;
-// m:=r.getobject(r.indexfile);
-//  siteindex.loadfromStream(m);
 
 end.

packages/fcl-xml/src/dom.pp

@@ -3217,7 +3217,7 @@ begin
     if Pointer(FCurrBlock) = Pointer(FCurrExtent) + sizeof(TExtent) then
       AddExtent(FCurrExtentSize * 2);
     Result := FCurrBlock;
-    Dec(PChar(FCurrBlock), FElementSize);
+    Dec(PAnsiChar(FCurrBlock), FElementSize);
   end;
   AClass.InitInstance(Result);
   Result.FPool := Self;        // mark as used

packages/fcl-xml/src/xmlutils.pp

@@ -55,7 +55,7 @@ type
     FBucketCount: LongWord;
     FBucket: PPHashItem;
     FOwnsObjects: Boolean;
-    function Lookup(Key: PWideChar; KeyLength: Integer; var Found: Boolean; CanCreate: Boolean): PHashItem;
+    function Lookup(Key: PWideChar; KeyLength: Integer; out Found: Boolean; CanCreate: Boolean): PHashItem;
     procedure Resize(NewCapacity: LongWord);
   public
     constructor Create(InitSize: Integer; OwnObjects: Boolean);
@@ -73,7 +73,6 @@ type
 
 { another hash, for detecting duplicate namespaced attributes without memory allocations }
 
-  PWideString = ^WideString;
   PExpHashEntry = ^TExpHashEntry;
   TExpHashEntry = record
     rev: LongWord;
@@ -129,7 +128,7 @@ begin
   Result := Xml11Pg;
 end;
 
-function IsXml11Char(Value: PWideChar; var Index: Integer): Boolean; overload;
+function IsXml11Char(Value: PWideChar; var Index: Integer): Boolean;
 begin
   if (Value[Index] >= #$D800) and (Value[Index] <= #$DB7F) then
   begin
@@ -140,7 +139,7 @@ begin
     Result := False;
 end;
 
-function IsXml11Char(const Value: WideString; var Index: Integer): Boolean; overload;
+function IsXml11Char(const Value: WideString; var Index: Integer): Boolean;
 begin
   if (Value[Index] >= #$D800) and (Value[Index] <= #$DB7F) then
   begin
@@ -156,7 +155,7 @@ begin
   Result := IsXmlName(PWideChar(Value), Length(Value), Xml11);
 end;
 
-function IsXmlName(Value: PWideChar; Len: Integer; Xml11: Boolean = False): Boolean; overload;
+function IsXmlName(Value: PWideChar; Len: Integer; Xml11: Boolean = False): Boolean;
 var
   Pages: PByteArray;
   I: Integer;
@@ -424,7 +423,7 @@ begin
 end;
 
 function THashTable.Lookup(Key: PWideChar; KeyLength: Integer;
-  var Found: Boolean; CanCreate: Boolean): PHashItem;
+  out Found: Boolean; CanCreate: Boolean): PHashItem;
 var
   Entry: PPHashItem;
   h: LongWord;

rtl/inc/objpas.inc

@@ -619,8 +619,8 @@
                 end;
               etFieldValue:
                 begin
-                  //writeln('Doing etFieldValue cast of ', TObject(Instance).classname(), ' with offset = ', IEntry^.IOffset);
-                  Pointer(obj) := ppointer(Pbyte(Instance)+IEntry^.IOffset)^;
+                  // writeln('Doing etFieldValue cast of ', TObject(Instance).classname(), ' with offset = ', IEntry^.IOffset);
+                  Pointer(obj) := PPointer(Pbyte(Instance)+IEntry^.IOffset)^;
                 end;
               etVirtualMethodResult:
                 begin

rtl/win/systhrd.inc

@@ -72,8 +72,8 @@ CONST
     const
       threadvarblocksize : dword = 0;
 
-    var
-      TLSKey : Dword;
+    const
+      TLSKey : DWord = $ffffffff;
 
     procedure SysInitThreadvar(var offset : dword;size : dword);
       begin
@@ -104,16 +104,17 @@ CONST
       var
         dataindex : pointer;
         errorsave : dword;
-      begin
-{$ifdef win32}
+      begin	    
+{$ifdef dummy}
+        { it least in the on windows 7 x64, this still doesn't not work, fs:(0x2c) is
+          self referencing on this system (FK) }
         asm
           movl TLSKey,%edx
-          movl $0x2c,%eax
-          movl %fs:(%eax),%eax
+          movl %fs:(0x2c),%eax
           orl  %eax,%eax
           jnz  .LAddressInEAX
-          movl $0x18,%eax
-          movl %fs:(%eax),%eax
+		  { this works on Windows 7, but I don't know if it works on other OSes (FK) }
+          movl %fs:(0x18),%eax
           movl 0xe10(%eax,%edx,4),%eax
           jmp  .LToDataIndex
           .LAddressInEAX:
@@ -186,11 +187,12 @@ CONST
     procedure SysInitMultithreading;
       begin
         { do not check IsMultiThread, as program could have altered it, out of Delphi habit }
-        if TLSKey = 0 then
+        if TLSKey=$ffffffff then
          begin
            { We're still running in single thread mode, setup the TLS }
            TLSKey:=TlsAlloc;
            InitThreadVars(@SysRelocateThreadvar);
+		   { allocate the thread vars for the main thread }
            IsMultiThread:=true;
          end;
       end;
@@ -200,7 +202,7 @@ CONST
         if IsMultiThread then
          begin
            TlsFree(TLSKey);
-           TLSKey := 0;
+           TLSKey:=$ffffffff;
          end;
       end;
 

tests/test/cg/cdecl/taoc1.pp

@@ -1,3 +1,4 @@
+{ %fail }
 
 { first simple array of const test }
 

tests/webtbf/tw13971a.pp

@@ -0,0 +1,19 @@
+{ %fail }
+
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+  tc = class
+    function getx(i: longint): longint;
+    property prop[i: longint]: longint read getx;
+    default: longint;
+  end;
+
+function tc.getx(i: longint): longint;
+begin
+end;
+
+begin
+end.

tests/webtbf/tw13971b.pp

@@ -0,0 +1,19 @@
+{ %fail }
+
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+  tc = class
+    constructor test;
+    a: longint;
+  end;
+
+constructor tc.test;
+begin
+end;
+
+begin
+end.
+

tests/webtbf/tw13971c.pp

@@ -0,0 +1,19 @@
+{ %fail }
+
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+  tc = class
+    procedure test;
+    register: longint;
+  end;
+
+procedure tc.test;
+begin
+end;
+
+begin
+end.
+

tests/webtbf/tw13971d.pp

@@ -0,0 +1,18 @@
+{ %fail }
+
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+  tc = class
+    function getx(i: longint): longint;
+    default: longint;
+  end;
+
+function tc.getx(i: longint): longint;
+begin
+end;
+
+begin
+end.

tests/webtbf/tw13971e.pp

@@ -0,0 +1,18 @@
+{ %fail }
+
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+  tc = class
+    constructor create;
+    a: longint;
+  end;
+
+constructor tc.create;
+begin
+end;
+
+begin
+end.

tests/webtbf/tw13971f.pp

@@ -0,0 +1,18 @@
+{ %fail }
+
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+  tc = class
+    destructor destroy; override;
+    a: longint;
+  end;
+
+destructor tc.destroy;
+begin
+end;
+
+begin
+end.

tests/webtbs/tw14418.pp

@@ -0,0 +1,89 @@
+program project1;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Classes
+  { you can add units after this };
+
+type
+  IIntf1 = interface
+    ['{87776F0F-8CE0-4881-B969-C76F5A9CA517}']
+    procedure M1;
+  end;
+
+  IIntf2 = interface
+    ['{923C47DF-0A7E-4698-98B8-45175306CDF2}']
+    procedure M2;
+  end;
+
+  { TObjIntf2 }
+
+  TObjIntf2 = class(TInterfacedObject, IIntf2)
+    procedure M2;
+  end;
+
+  { TObj }
+
+  TObj = class(TInterfacedObject, IIntf1, IIntf2)
+    private
+      FObjIntf2:IIntf2;
+    public
+      constructor Create;
+
+      procedure M1;
+
+      //when implementing IIntf2 using delegation,
+      //TObj1.M1 is called instead of TObjIntf2
+      property I2:IIntf2 read FObjIntf2 implements IIntf2;
+
+      //when implementing M2 directly it works right.
+      //procedure M2;
+  end;
+
+{ TObjIntf2 }
+
+procedure TObjIntf2.M2;
+begin
+  Writeln('TObjIntf2.M2 called');
+end;
+
+{ TObj }
+
+constructor TObj.Create;
+begin
+  FObjIntf2:=TObjIntf2.Create;
+end;
+
+procedure TObj.M1;
+begin
+  Writeln('TObj.M1 called');
+  halt(1);
+end;
+
+{
+procedure TObj.M2;
+begin
+  Writeln('TObj.M2 called');
+end;
+}
+
+var O:TObj;
+    i1:IIntf1;
+    i2:IIntf2;
+begin
+  O:=TObj.Create;
+  i1:=O;
+
+  //all tries are unsuccessful
+  //i2:=O as IIntf2;
+  //(O as IIntf1).QueryInterface(IIntf2, i2);
+  i1.QueryInterface(IIntf2, i2);
+
+  //still calls TObj1.M1
+  i2.M2;
+end.
+