Index: packages/fpc/Jcl.lpk =================================================================== --- packages/fpc/Jcl.lpk (revision 3561) +++ packages/fpc/Jcl.lpk (working copy) @@ -7,11 +7,11 @@ - + - - + + @@ -19,12 +19,13 @@ + - + @@ -33,12 +34,16 @@ + + + + - + @@ -351,10 +356,10 @@ - - - - + + + + Index: packages/fpc/JclContainers.lpk =================================================================== --- packages/fpc/JclContainers.lpk (revision 3561) +++ packages/fpc/JclContainers.lpk (working copy) @@ -7,11 +7,11 @@ - + - - + + @@ -19,6 +19,7 @@ + @@ -33,12 +34,16 @@ + + + + - + @@ -106,10 +111,10 @@ - - - - + + + + Index: source/common/JclCompression.pas =================================================================== --- source/common/JclCompression.pas (revision 3561) +++ source/common/JclCompression.pas (working copy) @@ -727,7 +727,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/JclRTTI.pas =================================================================== --- source/common/JclRTTI.pas (revision 3561) +++ source/common/JclRTTI.pas (working copy) @@ -1878,7 +1878,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 @@ -2945,7 +2949,7 @@ end; var - PropCount: Integer; + PropCount: SizeInt; begin PropCount := 0; SetLength(Result, 16); Index: source/common/JclStreams.pas =================================================================== --- source/common/JclStreams.pas (revision 3561) +++ source/common/JclStreams.pas (working copy) @@ -467,9 +467,9 @@ function LoadBuffer: Boolean; function LoadPeekBuffer: Boolean; function InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean; virtual; abstract; - function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: Longint): Longint; virtual; + function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; virtual; function InternalSetNextChar(S: TStream; Ch: UCS4): Boolean; virtual; abstract; - function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: Longint): Longint; virtual; + function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; virtual; procedure InvalidateBuffers; public constructor Create(AStream: TStream; AOwnsStream: Boolean = False); virtual; @@ -513,9 +513,9 @@ FCodePage: Word; protected function InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean; override; - function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: Longint): Longint; override; + function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override; function InternalSetNextChar(S: TStream; Ch: UCS4): Boolean; override; - function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: Longint): Longint; override; + function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override; public constructor Create(AStream: TStream; AOwnsStream: Boolean = False); override; property CodePage: Word read FCodePage write FCodePage; @@ -524,9 +524,9 @@ TJclUTF8Stream = class(TJclStringStream) protected function InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean; override; - function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: Longint): Longint; override; + function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override; function InternalSetNextChar(S: TStream; Ch: UCS4): Boolean; override; - function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: Longint): Longint; override; + function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override; public constructor Create(AStream: TStream; AOwnsStream: Boolean = False); override; end; @@ -534,9 +534,9 @@ TJclUTF16Stream = class(TJclStringStream) protected function InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean; override; - function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: Longint): Longint; override; + function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override; function InternalSetNextChar(S: TStream; Ch: UCS4): Boolean; override; - function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: Longint): Longint; override; + function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override; public constructor Create(AStream: TStream; AOwnsStream: Boolean = False); override; end; @@ -549,9 +549,9 @@ FEncoding: TJclStringEncoding; protected function InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean; override; - function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: Longint): Longint; override; + function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override; function InternalSetNextChar(S: TStream; Ch: UCS4): Boolean; override; - function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: Longint): Longint; override; + function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override; public constructor Create(AStream: TStream; AOwnsStream: Boolean = False); override; function SkipBOM: LongInt; override; @@ -2362,7 +2362,7 @@ end; function TJclStringStream.InternalGetNextBuffer(S: TStream; - var Buffer: TUCS4Array; Start, Count: Integer): Longint; + var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; var Ch: UCS4; begin @@ -2383,7 +2383,7 @@ end; function TJclStringStream.InternalSetNextBuffer(S: TStream; - const Buffer: TUCS4Array; Start, Count: Integer): Longint; + const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; begin // override to optimize Result := 0; @@ -2848,7 +2848,7 @@ end; function TJclAnsiStream.InternalGetNextBuffer(S: TStream; - var Buffer: TUCS4Array; Start, Count: Integer): Longint; + var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; begin if FCodePage = CP_ACP then Result := AnsiGetNextBufferFromStream(S, Buffer, Start, Count) @@ -2865,7 +2865,7 @@ end; function TJclAnsiStream.InternalSetNextBuffer(S: TStream; - const Buffer: TUCS4Array; Start, Count: Integer): Longint; + const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; begin if FCodePage = CP_ACP then Result := AnsiSetNextBufferToStream(S, Buffer, Start, Count) @@ -2894,7 +2894,7 @@ end; function TJclUTF8Stream.InternalGetNextBuffer(S: TStream; - var Buffer: TUCS4Array; Start, Count: Integer): Longint; + var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; begin Result := UTF8GetNextBufferFromStream(S, Buffer, Start, Count); end; @@ -2905,7 +2905,7 @@ end; function TJclUTF8Stream.InternalSetNextBuffer(S: TStream; - const Buffer: TUCS4Array; Start, Count: Integer): Longint; + const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; begin Result := UTF8SetNextBufferToStream(S, Buffer, Start, Count); end; @@ -2928,7 +2928,7 @@ end; function TJclUTF16Stream.InternalGetNextBuffer(S: TStream; - var Buffer: TUCS4Array; Start, Count: Integer): Longint; + var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; begin Result := UTF16GetNextBufferFromStream(S, Buffer, Start, Count); end; @@ -2939,7 +2939,7 @@ end; function TJclUTF16Stream.InternalSetNextBuffer(S: TStream; - const Buffer: TUCS4Array; Start, Count: Integer): Longint; + const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; begin Result := UTF16SetNextBufferToStream(S, Buffer, Start, Count); end; @@ -3021,7 +3021,7 @@ end; function TJclAutoStream.InternalGetNextBuffer(S: TStream; - var Buffer: TUCS4Array; Start, Count: Integer): Longint; + var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; begin case FCodePage of CP_UTF8: @@ -3050,7 +3050,7 @@ end; function TJclAutoStream.InternalSetNextBuffer(S: TStream; - const Buffer: TUCS4Array; Start, Count: Integer): Longint; + const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; begin case FCodePage of CP_UTF8: Index: source/common/JclStringLists.pas =================================================================== --- source/common/JclStringLists.pas (revision 3561) +++ source/common/JclStringLists.pas (working copy) @@ -74,7 +74,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; @@ -200,7 +202,7 @@ end; type - TJclUpdateControl = class(TObject, IInterface) + TJclUpdateControl = class(TInterfacedObject, IInterface) private FStrings: TStrings; public @@ -211,8 +213,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; @@ -432,6 +446,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/JclSysInfo.pas =================================================================== --- source/common/JclSysInfo.pas (revision 3561) +++ source/common/JclSysInfo.pas (working copy) @@ -4286,17 +4286,17 @@ SETNZ Result {$ENDIF CPU32} {$IFDEF CPU64} - // PUSHFQ - PUSHFD + PUSHFQ + //PUSHFD POP RAX MOV RCX, RAX XOR RAX, ID_FLAG AND RCX, ID_FLAG PUSH RAX - // POPFQ - POPFD - // PUSHFQ - PUSHFD + POPFQ + //POPFD + PUSHFQ + //PUSHFD POP RAX AND RAX, ID_FLAG XOR RAX, RCX Index: source/common/JclSysUtils.pas =================================================================== --- source/common/JclSysUtils.pas (revision 3561) +++ source/common/JclSysUtils.pas (working copy) @@ -405,7 +405,7 @@ // interfaced persistent type - TJclInterfacedPersistent = class(TPersistent, IInterface) + TJclInterfacedPersistent = class(TInterfacedPersistent, IInterface) protected FOwnerInterface: IInterface; FRefCount: Integer; @@ -630,7 +630,7 @@ // thread safe support type - TJclIntfCriticalSection = class(TObject, IInterface) + TJclIntfCriticalSection = class(TInterfacedObject, IInterface) private FCriticalSection: TCriticalSection; public @@ -789,6 +789,10 @@ {$ENDIF HAS_UNIT_ANSISTRINGS} JclFileUtils, JclMath, JclResources, JclStrings, JclStringConversions, JclSysInfo, Variants; +{$IFDEF FPC} +function CancelIo(hFile: THandle): BOOL; stdcall; external 'kernel32' name 'CancelIo'; +{$ENDIF FPC} + // memory initialization procedure ResetMemory(out P; Size: Longint); begin @@ -2832,7 +2836,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 @@ -2874,7 +2882,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 @@ -2904,7 +2916,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); @@ -2912,7 +2928,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; @@ -2971,6 +2991,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 3561) +++ source/common/JclUnicode.pas (working copy) @@ -2752,7 +2752,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 @@ -2765,7 +2765,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); @@ -4723,7 +4724,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 @@ -4736,7 +4737,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/windows/JclCppException.pas =================================================================== --- source/windows/JclCppException.pas (revision 3561) +++ source/windows/JclCppException.pas (working copy) @@ -151,7 +151,7 @@ implementation uses - JclResources, JclHookExcept; + JclResources, JclHookExcept, Windows; type @@ -589,8 +589,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 @@ -611,14 +611,20 @@ '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} end; procedure JclUninstallCppExceptionFilter; begin if not HookInstalled then Exit; + {$IFDEF BORLAND} JclHookExcept.JclRemoveExceptFilter(@CppExceptObjProc); + {$ENDIF BORLAND} HookInstalled := False; end; Index: source/windows/JclHookExcept.pas =================================================================== --- source/windows/JclHookExcept.pas (revision 3561) +++ source/windows/JclHookExcept.pas (working copy) @@ -43,7 +43,7 @@ {$IFDEF UNITVERSIONING} JclUnitVersioning, {$ENDIF UNITVERSIONING} - Windows, SysUtils, Classes; + Windows, SysUtils, Classes, JclBase; type // Exception hooking notifiers routines @@ -105,7 +105,6 @@ implementation uses - JclBase, JclPeImage, JclSysInfo, JclSysUtils; @@ -566,6 +565,7 @@ end; function GetCppRtlBase: Pointer; +{$IFDEF BORLAND} const {$IFDEF COMPILER6} { Delphi/C++Builder 6 } CppRtlVersion = 60; @@ -586,11 +586,22 @@ 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 Index: source/windows/JclWin32.pas =================================================================== --- source/windows/JclWin32.pas (revision 3561) +++ source/windows/JclWin32.pas (working copy) @@ -66,8 +66,8 @@ Windows, SysUtils, {$IFNDEF FPC} AccCtrl, + {$ENDIF ~FPC} ActiveX, - {$ENDIF ~FPC} JclBase; {$HPPEMIT '#include '} @@ -3144,8 +3144,8 @@ function ReBaseImage64(CurrentImageName: PAnsiChar; SymbolPath: PAnsiChar; fReBase: BOOL; fRebaseSysfileOk: BOOL; fGoingDown: BOOL; CheckImageSize: ULONG; - var OldImageSize: TJclAddr; var OldImageBase: TJclAddr64; - var NewImageSize: TJclAddr; var NewImageBase: TJclAddr64; TimeStamp: ULONG): BOOL; stdcall; + var OldImageSize: TJclAddr32; var OldImageBase: TJclAddr64; + var NewImageSize: TJclAddr32; var NewImageBase: TJclAddr64; TimeStamp: ULONG): BOOL; stdcall; {$EXTERNALSYM ReBaseImage64} // line 199