From 1399b7f8fb18b237699c3870289e82113031f720 Mon Sep 17 00:00:00 2001 From: marco Date: Wed, 26 Aug 2009 20:13:55 +0000 Subject: [PATCH 01/10] * open chm in nonexclusive mode. Could cause problems on Windows Vista where filelocks last even longer after closing. git-svn-id: trunk@13599 - --- ide/wchmhwrap.pas | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ide/wchmhwrap.pas b/ide/wchmhwrap.pas index 331ff7f27b..c7d00bd59b 100644 --- a/ide/wchmhwrap.pas +++ b/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. From ec8364904cd3b8ec43ecca1e7f5c972ba152caad Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Wed, 26 Aug 2009 21:18:53 +0000 Subject: [PATCH 02/10] * set the size of the (invalid) page at address zero to 64kb for 32 bit Darwin platforms, so that no data can be placed below that address. This fixes the strange Windows-compatible resource API, which assumes that addresses <64kb do not exist. git-svn-id: trunk@13600 - --- compiler/systems/t_bsd.pas | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/compiler/systems/t_bsd.pas b/compiler/systems/t_bsd.pas index de8118b29e..c04d61a1d0 100644 --- a/compiler/systems/t_bsd.pas +++ b/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 From 612d58c80f80a7328f9efc651d575b3ae00b7a47 Mon Sep 17 00:00:00 2001 From: michael Date: Thu, 27 Aug 2009 18:40:17 +0000 Subject: [PATCH 03/10] * Patch from Dariusz Mazur to fix compilation with Delphi git-svn-id: trunk@13602 - --- packages/fcl-xml/src/dom.pp | 24 +++++++++++++++--------- packages/fcl-xml/src/xmlutils.pp | 26 +++++++++++++++++++++----- packages/fcl-xml/src/xmlwrite.pp | 6 ++++-- 3 files changed, 40 insertions(+), 16 deletions(-) diff --git a/packages/fcl-xml/src/dom.pp b/packages/fcl-xml/src/dom.pp index 6c1e3d0d27..e8032cb44a 100644 --- a/packages/fcl-xml/src/dom.pp +++ b/packages/fcl-xml/src/dom.pp @@ -43,6 +43,10 @@ uses // ------------------------------------------------------- // DOMException // ------------------------------------------------------- +{$ifndef fpc} +type + tFpList = tList; +{$endif} const @@ -101,6 +105,8 @@ type TDOMAttrDef = class; PNodePool = ^TNodePool; TNodePool = class; + TTabNodePool = array[0..0] of TNodePool; + PTabNodePool = ^TTabNodePool; // ------------------------------------------------------- @@ -430,7 +436,7 @@ type FEmptyNode: TDOMElement; FNodeLists: THashTable; FMaxPoolSize: Integer; - FPools: PNodePool; + FPools: PTabNodePool; FDocumentURI: DOMString; function GetDocumentElement: TDOMElement; function GetDocType: TDOMDocumentType; @@ -3167,24 +3173,24 @@ var sz: Integer; begin ext := FCurrExtent; - ptr := Pointer(FCurrBlock) + FElementSize; + ptrInt(ptr) := ptrInt(FCurrBlock) + FElementSize; sz := FCurrExtentSize; while Assigned(ext) do begin // call destructors for everyone still there - ptr_end := Pointer(ext) + sizeof(TExtent) + (sz - 1) * FElementSize; - while ptr <= ptr_end do + ptrInt(ptr_end) := ptrInt(ext) + sizeof(TExtent) + (sz - 1) * FElementSize; + while ptrInt(ptr) <= ptrInt(ptr_end) do begin if TDOMNode(ptr).FPool = Self then TObject(ptr).Destroy; - Inc(ptr, FElementSize); + Inc(ptrInt(ptr), FElementSize); end; // dispose the extent and pass to the next one next := ext^.Next; FreeMem(ext); ext := next; sz := sz div 2; - ptr := Pointer(ext) + sizeof(TExtent); + ptrInt(ptr) := ptrInt(ext) + sizeof(TExtent); end; inherited Destroy; end; @@ -3194,13 +3200,13 @@ var ext: PExtent; begin Assert((FCurrExtent = nil) or - (Pointer(FCurrBlock) = Pointer(FCurrExtent) + sizeof(TExtent))); + (ptrInt(FCurrBlock) = ptrInt(FCurrExtent) + sizeof(TExtent))); Assert(AElemCount > 0); GetMem(ext, sizeof(TExtent) + AElemCount * FElementSize); ext^.Next := FCurrExtent; // point to the beginning of the last block of extent - FCurrBlock := TDOMNode(Pointer(ext) + sizeof(TExtent) + (AElemCount - 1) * FElementSize); + FCurrBlock := TDOMNode(ptrInt(ext) + sizeof(TExtent) + (AElemCount - 1) * FElementSize); FCurrExtent := ext; FCurrExtentSize := AElemCount; end; @@ -3214,7 +3220,7 @@ begin end else begin - if Pointer(FCurrBlock) = Pointer(FCurrExtent) + sizeof(TExtent) then + if ptrInt(FCurrBlock) = ptrInt(FCurrExtent) + sizeof(TExtent) then AddExtent(FCurrExtentSize * 2); Result := FCurrBlock; Dec(PChar(FCurrBlock), FElementSize); diff --git a/packages/fcl-xml/src/xmlutils.pp b/packages/fcl-xml/src/xmlutils.pp index 89aa8fc0e2..e1bc3c4228 100644 --- a/packages/fcl-xml/src/xmlutils.pp +++ b/packages/fcl-xml/src/xmlutils.pp @@ -14,14 +14,20 @@ **********************************************************************} unit xmlutils; -{$mode objfpc} -{$H+} +{$ifdef fpc} +{$MODE objfpc}{$H+} +{$endif} interface uses SysUtils; + {$IFNDEF FPC} + +type ptrint=integer; +{$ENDIF} + function IsXmlName(const Value: WideString; Xml11: Boolean = False): Boolean; overload; function IsXmlName(Value: PWideChar; Len: Integer; Xml11: Boolean = False): Boolean; overload; function IsXmlNames(const Value: WideString; Xml11: Boolean = False): Boolean; @@ -38,6 +44,7 @@ function WStrLIComp(S1, S2: PWideChar; Len: Integer): Integer; { a simple hash table with WideString keys } type + PTabPHashItem = ^TTabPHashItem; PPHashItem = ^PHashItem; PHashItem = ^THashItem; THashItem = record @@ -46,6 +53,7 @@ type Next: PHashItem; Data: TObject; end; + TTabPHashItem = array[0..0] of pHashItem; THashForEach = function(Entry: PHashItem; arg: Pointer): Boolean; @@ -53,7 +61,7 @@ type private FCount: LongWord; FBucketCount: LongWord; - FBucket: PPHashItem; + FBucket: PTabPHashItem; FOwnsObjects: Boolean; function Lookup(Key: PWideChar; KeyLength: Integer; var Found: Boolean; CanCreate: Boolean): PHashItem; procedure Resize(NewCapacity: LongWord); @@ -82,12 +90,15 @@ type lname: PWideChar; lnameLen: Integer; end; + PTabExpHashEntry = ^TTabExpHashEntry; + tTabExpHashEntry = array[0..0] of TExpHashEntry; + TDblHashArray = class(TObject) private FSizeLog: Integer; FRevision: LongWord; - FData: PExpHashEntry; + FData: PTabExpHashEntry; public procedure Init(NumSlots: Integer); function Locate(uri: PWideString; localName: PWideChar; localLength: Integer): Boolean; @@ -347,7 +358,11 @@ end; function KeyCompare(const Key1: WideString; Key2: Pointer; Key2Len: Integer): Boolean; begin + {$IFDEF FPC} Result := (Length(Key1)=Key2Len) and (CompareWord(Pointer(Key1)^, Key2^, Key2Len) = 0); + {$ELSE} + Result := comparemem(Pointer(Key1),key2,key2len*2); + {$ENDIF} end; { THashTable } @@ -461,7 +476,8 @@ end; procedure THashTable.Resize(NewCapacity: LongWord); var - p, chain: PPHashItem; + p : PTabPHashItem; + chain: PPHashItem; i: Integer; e, n: PHashItem; begin diff --git a/packages/fcl-xml/src/xmlwrite.pp b/packages/fcl-xml/src/xmlwrite.pp index 3586d77e1c..ee9b017c86 100644 --- a/packages/fcl-xml/src/xmlwrite.pp +++ b/packages/fcl-xml/src/xmlwrite.pp @@ -17,8 +17,10 @@ unit XMLWrite; -{$MODE objfpc} -{$H+} + +{$ifdef fpc} +{$MODE objfpc}{$H+} +{$endif} interface From f853ac4c63ffb411f2e7dfe9c7884a8d46b3b0e4 Mon Sep 17 00:00:00 2001 From: michael Date: Thu, 27 Aug 2009 20:10:54 +0000 Subject: [PATCH 04/10] * Undid previous patch, because not all compiles git-svn-id: trunk@13603 - --- packages/fcl-xml/src/dom.pp | 24 +++++++++--------------- packages/fcl-xml/src/xmlutils.pp | 26 +++++--------------------- packages/fcl-xml/src/xmlwrite.pp | 6 ++---- 3 files changed, 16 insertions(+), 40 deletions(-) diff --git a/packages/fcl-xml/src/dom.pp b/packages/fcl-xml/src/dom.pp index e8032cb44a..6c1e3d0d27 100644 --- a/packages/fcl-xml/src/dom.pp +++ b/packages/fcl-xml/src/dom.pp @@ -43,10 +43,6 @@ uses // ------------------------------------------------------- // DOMException // ------------------------------------------------------- -{$ifndef fpc} -type - tFpList = tList; -{$endif} const @@ -105,8 +101,6 @@ type TDOMAttrDef = class; PNodePool = ^TNodePool; TNodePool = class; - TTabNodePool = array[0..0] of TNodePool; - PTabNodePool = ^TTabNodePool; // ------------------------------------------------------- @@ -436,7 +430,7 @@ type FEmptyNode: TDOMElement; FNodeLists: THashTable; FMaxPoolSize: Integer; - FPools: PTabNodePool; + FPools: PNodePool; FDocumentURI: DOMString; function GetDocumentElement: TDOMElement; function GetDocType: TDOMDocumentType; @@ -3173,24 +3167,24 @@ var sz: Integer; begin ext := FCurrExtent; - ptrInt(ptr) := ptrInt(FCurrBlock) + FElementSize; + ptr := Pointer(FCurrBlock) + FElementSize; sz := FCurrExtentSize; while Assigned(ext) do begin // call destructors for everyone still there - ptrInt(ptr_end) := ptrInt(ext) + sizeof(TExtent) + (sz - 1) * FElementSize; - while ptrInt(ptr) <= ptrInt(ptr_end) do + ptr_end := Pointer(ext) + sizeof(TExtent) + (sz - 1) * FElementSize; + while ptr <= ptr_end do begin if TDOMNode(ptr).FPool = Self then TObject(ptr).Destroy; - Inc(ptrInt(ptr), FElementSize); + Inc(ptr, FElementSize); end; // dispose the extent and pass to the next one next := ext^.Next; FreeMem(ext); ext := next; sz := sz div 2; - ptrInt(ptr) := ptrInt(ext) + sizeof(TExtent); + ptr := Pointer(ext) + sizeof(TExtent); end; inherited Destroy; end; @@ -3200,13 +3194,13 @@ var ext: PExtent; begin Assert((FCurrExtent = nil) or - (ptrInt(FCurrBlock) = ptrInt(FCurrExtent) + sizeof(TExtent))); + (Pointer(FCurrBlock) = Pointer(FCurrExtent) + sizeof(TExtent))); Assert(AElemCount > 0); GetMem(ext, sizeof(TExtent) + AElemCount * FElementSize); ext^.Next := FCurrExtent; // point to the beginning of the last block of extent - FCurrBlock := TDOMNode(ptrInt(ext) + sizeof(TExtent) + (AElemCount - 1) * FElementSize); + FCurrBlock := TDOMNode(Pointer(ext) + sizeof(TExtent) + (AElemCount - 1) * FElementSize); FCurrExtent := ext; FCurrExtentSize := AElemCount; end; @@ -3220,7 +3214,7 @@ begin end else begin - if ptrInt(FCurrBlock) = ptrInt(FCurrExtent) + sizeof(TExtent) then + if Pointer(FCurrBlock) = Pointer(FCurrExtent) + sizeof(TExtent) then AddExtent(FCurrExtentSize * 2); Result := FCurrBlock; Dec(PChar(FCurrBlock), FElementSize); diff --git a/packages/fcl-xml/src/xmlutils.pp b/packages/fcl-xml/src/xmlutils.pp index e1bc3c4228..89aa8fc0e2 100644 --- a/packages/fcl-xml/src/xmlutils.pp +++ b/packages/fcl-xml/src/xmlutils.pp @@ -14,20 +14,14 @@ **********************************************************************} unit xmlutils; -{$ifdef fpc} -{$MODE objfpc}{$H+} -{$endif} +{$mode objfpc} +{$H+} interface uses SysUtils; - {$IFNDEF FPC} - -type ptrint=integer; -{$ENDIF} - function IsXmlName(const Value: WideString; Xml11: Boolean = False): Boolean; overload; function IsXmlName(Value: PWideChar; Len: Integer; Xml11: Boolean = False): Boolean; overload; function IsXmlNames(const Value: WideString; Xml11: Boolean = False): Boolean; @@ -44,7 +38,6 @@ function WStrLIComp(S1, S2: PWideChar; Len: Integer): Integer; { a simple hash table with WideString keys } type - PTabPHashItem = ^TTabPHashItem; PPHashItem = ^PHashItem; PHashItem = ^THashItem; THashItem = record @@ -53,7 +46,6 @@ type Next: PHashItem; Data: TObject; end; - TTabPHashItem = array[0..0] of pHashItem; THashForEach = function(Entry: PHashItem; arg: Pointer): Boolean; @@ -61,7 +53,7 @@ type private FCount: LongWord; FBucketCount: LongWord; - FBucket: PTabPHashItem; + FBucket: PPHashItem; FOwnsObjects: Boolean; function Lookup(Key: PWideChar; KeyLength: Integer; var Found: Boolean; CanCreate: Boolean): PHashItem; procedure Resize(NewCapacity: LongWord); @@ -90,15 +82,12 @@ type lname: PWideChar; lnameLen: Integer; end; - PTabExpHashEntry = ^TTabExpHashEntry; - tTabExpHashEntry = array[0..0] of TExpHashEntry; - TDblHashArray = class(TObject) private FSizeLog: Integer; FRevision: LongWord; - FData: PTabExpHashEntry; + FData: PExpHashEntry; public procedure Init(NumSlots: Integer); function Locate(uri: PWideString; localName: PWideChar; localLength: Integer): Boolean; @@ -358,11 +347,7 @@ end; function KeyCompare(const Key1: WideString; Key2: Pointer; Key2Len: Integer): Boolean; begin - {$IFDEF FPC} Result := (Length(Key1)=Key2Len) and (CompareWord(Pointer(Key1)^, Key2^, Key2Len) = 0); - {$ELSE} - Result := comparemem(Pointer(Key1),key2,key2len*2); - {$ENDIF} end; { THashTable } @@ -476,8 +461,7 @@ end; procedure THashTable.Resize(NewCapacity: LongWord); var - p : PTabPHashItem; - chain: PPHashItem; + p, chain: PPHashItem; i: Integer; e, n: PHashItem; begin diff --git a/packages/fcl-xml/src/xmlwrite.pp b/packages/fcl-xml/src/xmlwrite.pp index ee9b017c86..3586d77e1c 100644 --- a/packages/fcl-xml/src/xmlwrite.pp +++ b/packages/fcl-xml/src/xmlwrite.pp @@ -17,10 +17,8 @@ unit XMLWrite; - -{$ifdef fpc} -{$MODE objfpc}{$H+} -{$endif} +{$MODE objfpc} +{$H+} interface From e9e643934507ed2205cbbaf24dcadacf637a6072 Mon Sep 17 00:00:00 2001 From: sergei Date: Sat, 29 Aug 2009 18:11:08 +0000 Subject: [PATCH 05/10] * dom.pp: fixed one possible reason of crashing in Delphi 2009 * xmlutils.pp: clean up git-svn-id: trunk@13604 - --- packages/fcl-xml/src/dom.pp | 2 +- packages/fcl-xml/src/xmlutils.pp | 11 +++++------ 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/packages/fcl-xml/src/dom.pp b/packages/fcl-xml/src/dom.pp index 6c1e3d0d27..f011e2eade 100644 --- a/packages/fcl-xml/src/dom.pp +++ b/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 diff --git a/packages/fcl-xml/src/xmlutils.pp b/packages/fcl-xml/src/xmlutils.pp index 89aa8fc0e2..0810d3f6fa 100644 --- a/packages/fcl-xml/src/xmlutils.pp +++ b/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; From a8c6d9ec3addd7ec54011fd2a1dd173d70c3faa3 Mon Sep 17 00:00:00 2001 From: florian Date: Sat, 29 Aug 2009 20:46:06 +0000 Subject: [PATCH 06/10] * partially reverted 13571, I didn't get it work on W7 x64 in win32 mode * use $ffffffff to signal an unsed TLSKey, 0 is a valid TLSKey and could be returned by Windows in theory git-svn-id: trunk@13608 - --- rtl/win/systhrd.inc | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/rtl/win/systhrd.inc b/rtl/win/systhrd.inc index b30b97547a..035fa373ae 100644 --- a/rtl/win/systhrd.inc +++ b/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; From e8dff46f8e74f97041f4fe7719f73c35e26298f2 Mon Sep 17 00:00:00 2001 From: florian Date: Sun, 30 Aug 2009 08:01:10 +0000 Subject: [PATCH 07/10] * several small bugs in the handling of implements fixed, resolves #14418 git-svn-id: trunk@13615 - --- .gitattributes | 1 + compiler/nobj.pas | 8 ++-- compiler/pdecvar.pas | 7 +++- compiler/symdef.pas | 4 +- rtl/inc/objpas.inc | 4 +- tests/webtbs/tw14418.pp | 88 +++++++++++++++++++++++++++++++++++++++++ 6 files changed, 103 insertions(+), 9 deletions(-) create mode 100644 tests/webtbs/tw14418.pp diff --git a/.gitattributes b/.gitattributes index abb467f2f1..b508a07e73 100644 --- a/.gitattributes +++ b/.gitattributes @@ -9223,6 +9223,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 diff --git a/compiler/nobj.pas b/compiler/nobj.pas index 79ce7db8a5..36a1305ef2 100644 --- a/compiler/nobj.pas +++ b/compiler/nobj.pas @@ -518,8 +518,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 @@ -536,7 +536,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; @@ -1106,9 +1106,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)); diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas index 958e0bf2c8..b8d17543d2 100644 --- a/compiler/pdecvar.pas +++ b/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; diff --git a/compiler/symdef.pas b/compiler/symdef.pas index c51fccc3ab..39af4d4d2b 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -2071,7 +2071,7 @@ implementation begin result:=true; end; - + procedure tclassrefdef.reset; begin @@ -4397,7 +4397,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 } diff --git a/rtl/inc/objpas.inc b/rtl/inc/objpas.inc index c6c3d3f03d..41539644db 100644 --- a/rtl/inc/objpas.inc +++ b/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 diff --git a/tests/webtbs/tw14418.pp b/tests/webtbs/tw14418.pp new file mode 100644 index 0000000000..77e30362e9 --- /dev/null +++ b/tests/webtbs/tw14418.pp @@ -0,0 +1,88 @@ +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'); +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. + From 1b6657cf21fb25acf14910049a6a5d28ffa1456a Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Sun, 30 Aug 2009 08:33:43 +0000 Subject: [PATCH 08/10] * make test fail if the wrong method is called git-svn-id: trunk@13616 - --- tests/webtbs/tw14418.pp | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/webtbs/tw14418.pp b/tests/webtbs/tw14418.pp index 77e30362e9..1e107f6a3b 100644 --- a/tests/webtbs/tw14418.pp +++ b/tests/webtbs/tw14418.pp @@ -61,6 +61,7 @@ end; procedure TObj.M1; begin Writeln('TObj.M1 called'); + halt(1); end; { From ae6200ce72d0fec39781d710a1962fbd273ffe2f Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Sun, 30 Aug 2009 08:37:53 +0000 Subject: [PATCH 09/10] + tests forgotten to commit as part of r13334 git-svn-id: trunk@13617 - --- .gitattributes | 6 ++++++ tests/webtbf/tw13971a.pp | 19 +++++++++++++++++++ tests/webtbf/tw13971b.pp | 19 +++++++++++++++++++ tests/webtbf/tw13971c.pp | 19 +++++++++++++++++++ tests/webtbf/tw13971d.pp | 18 ++++++++++++++++++ tests/webtbf/tw13971e.pp | 18 ++++++++++++++++++ tests/webtbf/tw13971f.pp | 18 ++++++++++++++++++ 7 files changed, 117 insertions(+) create mode 100644 tests/webtbf/tw13971a.pp create mode 100644 tests/webtbf/tw13971b.pp create mode 100644 tests/webtbf/tw13971c.pp create mode 100644 tests/webtbf/tw13971d.pp create mode 100644 tests/webtbf/tw13971e.pp create mode 100644 tests/webtbf/tw13971f.pp diff --git a/.gitattributes b/.gitattributes index b508a07e73..7a756f704d 100644 --- a/.gitattributes +++ b/.gitattributes @@ -8625,6 +8625,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 diff --git a/tests/webtbf/tw13971a.pp b/tests/webtbf/tw13971a.pp new file mode 100644 index 0000000000..8a3c288e78 --- /dev/null +++ b/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. diff --git a/tests/webtbf/tw13971b.pp b/tests/webtbf/tw13971b.pp new file mode 100644 index 0000000000..620bc6e1fe --- /dev/null +++ b/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. + diff --git a/tests/webtbf/tw13971c.pp b/tests/webtbf/tw13971c.pp new file mode 100644 index 0000000000..b506c3dcb4 --- /dev/null +++ b/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. + diff --git a/tests/webtbf/tw13971d.pp b/tests/webtbf/tw13971d.pp new file mode 100644 index 0000000000..5fb5ff317c --- /dev/null +++ b/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. diff --git a/tests/webtbf/tw13971e.pp b/tests/webtbf/tw13971e.pp new file mode 100644 index 0000000000..b68a420537 --- /dev/null +++ b/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. diff --git a/tests/webtbf/tw13971f.pp b/tests/webtbf/tw13971f.pp new file mode 100644 index 0000000000..531faa9201 --- /dev/null +++ b/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. From ceb547d0275f3e15888871b71623457000369e47 Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Sun, 30 Aug 2009 08:52:38 +0000 Subject: [PATCH 10/10] * only allow cdecl "array of const" parameters for procvars and for external routines (just like "varargs"), because if implemented in Pascal then on the callee side this array of const parameter is treated as a Pascal- style array of const * don't give the "cdecl'ared functions have no high parameter" warning for array of const parameters for cdecl external routines and procvars git-svn-id: trunk@13618 - --- compiler/pdecsub.pas | 8 ++++++-- tests/test/cg/cdecl/taoc1.pp | 1 + 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas index 3025847c47..e210892aac 100644 --- a/compiler/pdecsub.pas +++ b/compiler/pdecsub.pas @@ -298,8 +298,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 diff --git a/tests/test/cg/cdecl/taoc1.pp b/tests/test/cg/cdecl/taoc1.pp index 9620bea45e..3512904535 100644 --- a/tests/test/cg/cdecl/taoc1.pp +++ b/tests/test/cg/cdecl/taoc1.pp @@ -1,3 +1,4 @@ +{ %fail } { first simple array of const test }