Index: packages/fpc/Jcl.lpk =================================================================== --- packages/fpc/Jcl.lpk (revision 3644) +++ packages/fpc/Jcl.lpk (working copy) @@ -1,17 +1,16 @@ - + - - + - - + + @@ -19,26 +18,26 @@ + - + - - - - - + + + + - + @@ -351,10 +350,10 @@ - - - - + + + + Index: packages/fpc/JclContainers.lpk =================================================================== --- packages/fpc/JclContainers.lpk (revision 3644) +++ packages/fpc/JclContainers.lpk (working copy) @@ -7,11 +7,11 @@ - + - - + + @@ -19,6 +19,7 @@ + @@ -33,6 +34,10 @@ + + + + @@ -106,10 +111,10 @@ - - - - + + + + Index: source/common/JclAbstractContainers.pas =================================================================== --- source/common/JclAbstractContainers.pas (revision 3644) +++ source/common/JclAbstractContainers.pas (working copy) @@ -701,9 +701,9 @@ procedure AppendToStrings(Strings: TJclWideStrings); procedure AppendFromStrings(Strings: TJclWideStrings); function GetAsStrings: TJclWideStrings; - function GetAsDelimited(const Separator: WideString = WideLineBreak): WideString; - procedure AppendDelimited(const AString: WideString; const Separator: WideString = WideLineBreak); - procedure LoadDelimited(const AString: WideString; const Separator: WideString = WideLineBreak); + function GetAsDelimited(const Separator: WideString {$IFNDEF FPC}= WideLineBreak {$ENDIF}): WideString; + procedure AppendDelimited(const AString: WideString; const Separator: WideString {$IFNDEF FPC}= WideLineBreak {$ENDIF}); + procedure LoadDelimited(const AString: WideString; const Separator: WideString {$IFNDEF FPC}= WideLineBreak {$ENDIF}); end; {$IFDEF SUPPORTS_UNICODE_STRING} @@ -1372,12 +1372,12 @@ else begin case FEncoding of - seISO: + JclContainerIntf.seISO: if FCaseSensitive then Result := AnsiStrSimpleHashConvert(AString) else Result := AnsiStrSimpleHashConvertI(AString); - seUTF8: + JclContainerIntf.seUTF8: if FCaseSensitive then Result := AnsiStrSimpleHashConvertU(AString) else @@ -1395,7 +1395,7 @@ else begin case FEncoding of - seISO, seUTF8: + JclContainerIntf.seISO, JclContainerIntf.seUTF8: if FCaseSensitive then Result := AnsiStrSimpleCompare(A, B) else @@ -1416,7 +1416,7 @@ else begin case FEncoding of - seISO, seUTF8: + JclContainerIntf.seISO, JclContainerIntf.seUTF8: if FCaseSensitive then Result := AnsiStrSimpleEqualityCompare(A, B) else Index: source/common/JclAlgorithms.pas =================================================================== --- source/common/JclAlgorithms.pas (revision 3644) +++ source/common/JclAlgorithms.pas (working copy) @@ -494,9 +494,9 @@ {$ENDIF HAS_UNIT_ANSISTRINGS} System.SysUtils, {$ELSE ~HAS_UNITSCOPE} - {$IFDEF COMPILER11_UP} + {.$IFDEF COMPILER11_UP} Windows, - {$ENDIF COMPILER11_UP} + {.$ENDIF COMPILER11_UP} {$IFDEF HAS_UNIT_ANSISTRINGS} AnsiStrings, {$ENDIF HAS_UNIT_ANSISTRINGS} @@ -4130,4 +4130,4 @@ UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} -end. \ No newline at end of file +end. Index: source/common/JclAnsiStrings.pas =================================================================== --- source/common/JclAnsiStrings.pas (revision 3644) +++ source/common/JclAnsiStrings.pas (working copy) @@ -506,8 +506,8 @@ function ArrayOf(List: TJclAnsiStrings): TDynStringArray; overload; -function AnsiCompareNaturalStr(const S1, S2: AnsiString): SizeInt; -function AnsiCompareNaturalText(const S1, S2: AnsiString): SizeInt; +function AnsiCompareNaturalStr(const S1, S2: AnsiString): SizeInt;overload; +function AnsiCompareNaturalText(const S1, S2: AnsiString): SizeInt;overload; // internal structures published to make function inlining working const Index: source/common/JclBase.pas =================================================================== --- source/common/JclBase.pas (revision 3644) +++ source/common/JclBase.pas (working copy) @@ -588,7 +588,7 @@ procedure GetMem(out P; Size: Longint); begin Pointer(P) := nil; - GetMem(Pointer(P), Size); + System.GetMem(Pointer(P), Size); end; {$ENDIF FPC} Index: source/common/JclCompression.pas =================================================================== --- source/common/JclCompression.pas (revision 3644) +++ source/common/JclCompression.pas (working copy) @@ -745,7 +745,7 @@ TJclStreamAccess = (saCreate, saReadOnly, saReadOnlyDenyNone, saWriteOnly, saReadWrite); { TJclCompressionArchive is not ref-counted } - TJclCompressionArchive = class(TObject, IInterface) + TJclCompressionArchive = class(TInterfacedObject, IInterface) private FOnProgress: TJclCompressionProgressEvent; FOnRatio: TJclCompressionRatioEvent; Index: source/common/JclDateTime.pas =================================================================== --- source/common/JclDateTime.pas (revision 3644) +++ source/common/JclDateTime.pas (working copy) @@ -87,7 +87,7 @@ { Encode / Decode functions } -function EncodeDate(const Year: Integer; Month, Day: Word): TDateTime; +function EncodeDate(const Year: Integer; Month, Day: Word): TDateTime;overload; procedure DecodeDate(Date: TDateTime; out Year, Month, Day: Word); overload; procedure DecodeDate(Date: TDateTime; out Year: Integer; out Month, Day: Word); overload; procedure DecodeDate(Date: TDateTime; out Year, Month, Day: Integer); overload; Index: source/common/JclRTTI.pas =================================================================== --- source/common/JclRTTI.pas (revision 3644) +++ source/common/JclRTTI.pas (working copy) @@ -1890,7 +1890,11 @@ AInstance := GetObjectProp(FInstance, PropInfo); if AInstance <> nil then begin + {$IFNDEF FPC} SubClassTypeInfo := TJclObjClassTypeInfo.Create(PropInfo.PropType^, Prefix, AInstance); + {$ELSE} + SubClassTypeInfo := TJclObjClassTypeInfo.Create(PropInfo.PropType, Prefix, AInstance); + {$ENDIF} Result := SubClassTypeInfo.ObjPropNames[Suffix]; end else Index: source/common/JclStringLists.pas =================================================================== --- source/common/JclStringLists.pas (revision 3644) +++ source/common/JclStringLists.pas (working copy) @@ -82,7 +82,9 @@ function GetObjects(Index: Integer): TObject; function GetTextStr: string; function GetValue(const Name: string): string; + {$IFNDEF FPC} function Find(const S: string; var Index: Integer): Boolean; + {$ENDIF FPC} function IndexOf(const S: string): Integer; function GetCaseSensitive: Boolean; function GetDuplicates: TDuplicates; @@ -208,7 +210,7 @@ end; type - TJclUpdateControl = class(TObject, IInterface) + TJclUpdateControl = class(TInterfacedObject, IInterface) private FStrings: TStrings; public @@ -219,8 +221,20 @@ function _Release: Integer; stdcall; end; - TJclStringList = class(TStringList, IJclStringList) + TJclInterfacedStringList = class(TStringList, IInterface) private + FOwnerInterface: IInterface; + protected + { IInterface } + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; stdcall; + procedure AfterConstruction; override; + end; + + TJclStringList = class(TJclInterfacedStringList, IJclStringList) + private FObjectsMode: TJclStringListObjectsMode; FSelfAsInterface: IJclStringList; FLastRegExPattern: string; @@ -444,6 +458,45 @@ Result := JclStringList.Add(A); end; +//=== { TJclInterfacedStringList } ============================================== + +procedure TJclInterfacedStringList.AfterConstruction; +Var + MyOwner : TPersistent; +begin + inherited; + MyOwner := GetOwner; + if assigned(MyOwner) then + MyOwner.GetInterface(IUnknown,FOwnerInterface); +end; + + +function TJclInterfacedStringList._AddRef: Integer;stdcall; +begin + if assigned(FOwnerInterface) then + Result:=FOwnerInterface._AddRef + else + Result:=-1; +end; + + +function TJclInterfacedStringList._Release: Integer;stdcall; +begin + if assigned(FOwnerInterface) then + Result:=FOwnerInterface._Release + else + Result:=-1; +end; + + +function TJclInterfacedStringList.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult;stdcall; +begin + if GetInterface(IID, Obj) then + Result:=0 + else + Result:=HResult($80004002); +end; + //=== { TJclStringList } ===================================================== function TJclStringList.Add(const A: array of const): IJclStringList; Index: source/common/JclStrings.pas =================================================================== --- source/common/JclStrings.pas (revision 3644) +++ source/common/JclStrings.pas (working copy) @@ -592,8 +592,8 @@ {$ENDIF SUPPORTS_UNICODE_STRING} // natural comparison functions -function CompareNaturalStr(const S1, S2: string): SizeInt; -function CompareNaturalText(const S1, S2: string): SizeInt; +function CompareNaturalStr(const S1, S2: string): SizeInt;overload; +function CompareNaturalText(const S1, S2: string): SizeInt;overload; {$IFNDEF UNICODE_RTL_DATABASE} // internal structures published to make function inlining working Index: source/common/JclSynch.pas =================================================================== --- source/common/JclSynch.pas (revision 3644) +++ source/common/JclSynch.pas (working copy) @@ -86,8 +86,10 @@ function LockedInc(var Target: Int64): Int64; overload; function LockedSub(var Target: Int64; Value: Int64): Int64; overload; +{$IFNDEF FPC} function LockedDec(var Target: NativeInt): NativeInt; overload; function LockedInc(var Target: NativeInt): NativeInt; overload; +{$ENDIF FPC} {$ENDIF CPU64} // TJclDispatcherObject @@ -729,6 +731,7 @@ ADD RAX, RDX end; +{$IFNDEF FPC} function LockedDec(var Target: NativeInt): NativeInt; asm // --> RCX Target @@ -746,6 +749,7 @@ LOCK XADD [RCX], RAX INC RAX end; +{$ENDIF FPC} {$ENDIF CPU64} //=== { TJclDispatcherObject } =============================================== Index: source/common/JclSysInfo.pas =================================================================== --- source/common/JclSysInfo.pas (revision 3644) +++ source/common/JclSysInfo.pas (working copy) @@ -4321,6 +4321,9 @@ SETNZ Result {$ENDIF CPU32} {$IFDEF CPU64} + {$IFDEF FPC} + {$DEFINE DELPHI64_TEMPORARY} + {$ENDIF FPC} {$IFDEF DELPHI64_TEMPORARY} PUSHFQ {$ELSE ~DELPHI64_TEMPORARY} @@ -4345,6 +4348,9 @@ AND RAX, ID_FLAG XOR RAX, RCX SETNZ Result + {$IFDEF FPC} + {$UNDEF DELPHI64_TEMPORARY} + {$ENDIF FPC} {$ENDIF CPU64} end; {$IFNDEF DELPHI64_TEMPORARY} Index: source/common/JclSysUtils.pas =================================================================== --- source/common/JclSysUtils.pas (revision 3644) +++ source/common/JclSysUtils.pas (working copy) @@ -412,7 +412,7 @@ // interfaced persistent type - TJclInterfacedPersistent = class(TPersistent, IInterface) + TJclInterfacedPersistent = class(TInterfacedPersistent, IInterface) protected FOwnerInterface: IInterface; FRefCount: Integer; @@ -637,7 +637,7 @@ // thread safe support type - TJclIntfCriticalSection = class(TObject, IInterface) + TJclIntfCriticalSection = class(TInterfacedObject, IInterface) private FCriticalSection: TCriticalSection; public @@ -812,6 +812,10 @@ {$ENDIF ~HAS_UNITSCOPE} JclFileUtils, JclMath, JclResources, JclStrings, JclStringConversions, JclSysInfo; +{$IFDEF FPC} +function CancelIo(hFile: THandle): BOOL; stdcall; external 'kernel32' name 'CancelIo'; +{$ENDIF FPC} + // memory initialization procedure ResetMemory(out P; Size: Longint); begin @@ -2855,7 +2859,11 @@ end; InternalAbort := False; if AbortPtr <> nil then + {$IFDEF FPC} + AbortPtr^ := Byte(False) + {$ELSE} AbortPtr^ := False + {$ENDIF FPC} else AbortPtr := @InternalAbort; // init the array of events to wait for @@ -2897,7 +2905,11 @@ InternalExecuteReadPipe(ErrorPipeInfo, ErrorOverlapped); end; // event based loop + {$IFDEF FPC} + while not Boolean(AbortPtr^) do + {$ELSE} while not AbortPtr^ do + {$ENDIF} begin Index := WaitAlertableForMultipleObjects(WaitEvents, False, INFINITE); if Index = WAIT_OBJECT_0 then @@ -2927,7 +2939,11 @@ if ((Index = (WAIT_OBJECT_0 + 2)) and MergeError) or ((Index = (WAIT_OBJECT_0 + 3)) and not MergeError) then // event on abort + {$IFDEF FPC} + AbortPtr^ := Byte(True) + {$ELSE} AbortPtr^ := True + {$ENDIF FPC} else {$IFDEF DELPHI11_UP} RaiseLastOSError(Index); @@ -2935,7 +2951,11 @@ RaiseLastOSError; {$ENDIF DELPHI11_UP} end; + {$IFDEF FPC} + if Boolean(AbortPtr^) then + {$ELSE} if AbortPtr^ then + {$ENDIF FPC} TerminateProcess(ProcessEvent.Handle, Cardinal(ABORT_EXIT_CODE)); if (ProcessEvent.WaitForever = wrSignaled) and not GetExitCodeProcess(ProcessEvent.Handle, Result) then Result := $FFFFFFFF; @@ -2994,6 +3014,7 @@ pclose(Pipe); wait(nil); end; +end; {$ENDIF UNIX} if OutPipeInfo.Line <> '' then if Assigned(OutPipeInfo.TextHandler) then Index: source/common/JclUnicode.pas =================================================================== --- source/common/JclUnicode.pas (revision 3644) +++ source/common/JclUnicode.pas (working copy) @@ -1580,16 +1580,19 @@ SetLength(Categories[First], 256); if Categories[First, Second] = nil then SetLength(Categories[First, Second], 256); - {$IF SizeOf(TCharacterCategories) mod 4 <> 0} + {.$IF SizeOf(TCharacterCategories) mod 4 <> 0} + If SizeOf(TCharacterCategories) mod 4 <> 0 Then Begin // The array is allocated on the exact size, but the compiler generates // a 32 bit "BTS" instruction that accesses memory beyond the allocated block. - if Third < 255 then - Include(Categories[First, Second, Third], Category) + if Third < 255 then + Include(Categories[First, Second, Third], Category) + else + Categories[First, Second, Third] := Categories[First, Second, Third] + [Category]; + {.$ELSE} + end else - Categories[First, Second, Third] := Categories[First, Second, Third] + [Category]; - {$ELSE} - Include(Categories[First, Second, Third], Category); - {$IFEND} + Include(Categories[First, Second, Third], Category); + {.$IFEND} end; end; end; @@ -2839,7 +2842,7 @@ // Looks for all occurences of the pattern passed to FindPrepare and creates an // internal list of their positions. var - Start, Stop: SizeInt; + Start, Stop, CharCount: SizeInt; Run: PWideChar; RunLen: SizeInt; begin @@ -2852,7 +2855,8 @@ while Find(Run, RunLen, Start, Stop) do begin // store this result (consider text pointer movement)... - AddResult(Start + Run - Text, Stop + Run - Text); + CharCount := (TJclAddr(Run) - TJclAddr(Text)) div SizeOf(WideChar); + AddResult(Start + CharCount, Stop + CharCount); // ... and advance text position and length Inc(Run, Stop); Dec(RunLen, Stop); @@ -4810,7 +4814,7 @@ // Looks for all occurences of the pattern passed to FindPrepare and creates an // internal list of their positions. var - Start, Stop: SizeInt; + Start, Stop, CharCount: SizeInt; Run: PWideChar; RunLen: SizeInt; begin @@ -4823,7 +4827,8 @@ while ExecuteURE(0, Run, RunLen, Start, Stop) do begin // store this result (consider text pointer movement)... - AddResult(Start + Run - Text, Stop + Run - Text); + CharCount := (TJclAddr(Run) - TJclAddr(Text)) div SizeOf(WideChar); + AddResult(Start + CharCount, Stop + CharCount); // ... and advance text position and length Inc(Run, Stop); Dec(RunLen, Stop); Index: source/common/JclWideStrings.pas =================================================================== --- source/common/JclWideStrings.pas (revision 3644) +++ source/common/JclWideStrings.pas (working copy) @@ -847,11 +847,13 @@ // --> RCX Str XOR RAX, RAX // clear high order byte to be able to use 64bit operand below @@1: - MOV AX, WORD PTR [ECX] + //MOV AX, WORD PTR [ECX] + MOV AX, WORD PTR [RCX] OR RAX, RAX JZ @@2 XCHG AL, AH - MOV WORD PTR [ECX], AX + //MOV WORD PTR [ECX], AX + MOV WORD PTR [RCX], AX ADD ECX, 2 JMP @@1 @@2: Index: source/windows/JclAppInst.pas =================================================================== --- source/windows/JclAppInst.pas (revision 3644) +++ source/windows/JclAppInst.pas (working copy) @@ -742,7 +742,11 @@ ACLSize := SizeOf(TACL) + SizeOf(ACCESS_ALLOWED_ACE) + SizeOf(DWORD) + GetLengthSid(AccessSID); ACL := AllocMem(ACLSize); Win32Check(InitializeAcl(ACL^, ACLSize, ACL_REVISION)); + {$IFNDEF FPC} Win32Check(AddAccessAllowedAce(ACL^, ACL_REVISION, FILE_MAP_ALL_ACCESS, AccessSID)); + {$ELSE} + Win32Check(AddAccessAllowedAce(ACL, ACL_REVISION, FILE_MAP_ALL_ACCESS, AccessSID)); + {$ENDIF} Assert(IsValidAcl(ACL^)); // create the security descriptor Index: source/windows/JclCppException.pas =================================================================== --- source/windows/JclCppException.pas (revision 3644) +++ source/windows/JclCppException.pas (working copy) @@ -160,7 +160,7 @@ implementation uses - JclResources, JclHookExcept; + JclResources, JclHookExcept, Windows; type @@ -438,7 +438,9 @@ var OldAcquireExceptionProc: Pointer; + {$IFNDEF FPC} OldRaiseExceptionProc: TRaiseExceptionProc; + {$ENDIF FPC} procedure ExceptionAcquiredProc(Obj: Pointer); begin @@ -465,8 +467,10 @@ end; LastCppExcDesc := nil; + {$IFNDEF FPC} if Assigned(OldRaiseExceptionProc) then OldRaiseExceptionProc(ExceptionCode, ExceptionFlags, NumberOfArguments, Args); + {$ENDIF FPC} end; function EJclCppStdException.GetStdException: PJclCppStdException; @@ -676,8 +680,8 @@ { The exception object is a std::exception subclass and implements the virtual member function what(). } ExcObjectVTbl := Pointer(PCardinal(ExcObject)^); - WhatMethod := TCppTypeInfoWhatMethod(PCardinal( - Cardinal(ExcObjectVTbl) + SizeOf(Pointer))^); + WhatMethod := TCppTypeInfoWhatMethod(Pointer(PCardinal( + Cardinal(ExcObjectVTbl) + SizeOf(Pointer))^)); Result := EJclCppStdException.Create(ExcObject, String(WhatMethod(ExcObject)), PAnsiChar(ExcTypeName), Pointer(ExcDesc)); end @@ -698,7 +702,11 @@ 'Cannot install C++ exception filter: call JclHookExcept.JclHookExceptions() first!'); if HookInstalled then Exit; + {$IFDEF BORLAND} HookInstalled := JclHookExcept.JclAddExceptFilter(@CppExceptObjProc, npFirstChain); + {$ELSE} + HookInstalled := False; + {$ENDIF BORLAND} if HookInstalled then begin {$IFDEF COMPILER12_UP} // TODO: this may be supported for earlier versions of Delphi/C++Builder @@ -706,12 +714,14 @@ System.ExceptionAcquired := @ExceptionAcquiredProc; {$ENDIF COMPILER12_UP} + {$IFDEF BORLAND} OldRaiseExceptionProc := System.RaiseExceptionProc; {$IFDEF CPU32} System.RaiseExceptionProc := @RaiseExceptionProc; {$ELSE} System.RaiseExceptionProc := RaiseExceptionProc; {$ENDIF CPU32} + {$ENDIF BORLAND} end; end; @@ -722,12 +732,14 @@ {$IFDEF COMPILER12_UP} // TODO: this may be supported for earlier versions of Delphi/C++Builder System.ExceptionAcquired := OldAcquireExceptionProc; {$ENDIF COMPILER12_UP} + {$IFDEF BORLAND} {$IFDEF CPU32} System.RaiseExceptionProc := @OldRaiseExceptionProc; {$ELSE} System.RaiseExceptionProc := OldRaiseExceptionProc; {$ENDIF CPU32} JclHookExcept.JclRemoveExceptFilter(@CppExceptObjProc); + {$ENDIF BORLAND } HookInstalled := False; end; Index: source/windows/JclHookExcept.pas =================================================================== --- source/windows/JclHookExcept.pas (revision 3644) +++ source/windows/JclHookExcept.pas (working copy) @@ -46,7 +46,7 @@ {$IFDEF HAS_UNITSCOPE} Winapi.Windows, System.SysUtils, System.Classes; {$ELSE ~HAS_UNITSCOPE} - Windows, SysUtils, Classes; + Windows, SysUtils, Classes, JclBase; {$ENDIF ~HAS_UNITSCOPE} type @@ -109,7 +109,6 @@ implementation uses - JclBase, JclPeImage, JclSysInfo, JclSysUtils; @@ -575,6 +574,7 @@ end; function GetCppRtlBase: Pointer; +{$IFDEF BORLAND} const {$IFDEF COMPILER6} { Delphi/C++Builder 6 } CppRtlVersion = 60; @@ -595,12 +595,25 @@ in this case TJclPeMapImgHooks.ReplaceImport() is a no-op. The base module is also being hooked separately, so we're covered. } end; +{$ELSE} +begin + Result := NIL; +end; +{$ENDIF BORLAND} + function HasCppRtl: Boolean; +{$IFDEF BORLAND} begin Result := GetCppRtlBase <> TJclPeMapImgHooks.SystemBase; end; +{$ELSE} +begin + Result := False; +end; +{$ENDIF BORLAND} + function JclHookExceptions: Boolean; var RaiseExceptionAddressCache: Pointer; Index: source/windows/JclWin32.pas =================================================================== --- source/windows/JclWin32.pas (revision 3644) +++ source/windows/JclWin32.pas (working copy) @@ -71,8 +71,9 @@ {$ELSE ~HAS_UNITSCOPE} Windows, SysUtils, {$IFNDEF FPC} - AccCtrl, ActiveX, + AccCtrl, {$ENDIF ~FPC} + ActiveX, {$ENDIF ~HAS_UNITSCOPE} JclBase;