From d16280c40ce8b28a06fa2768cb7a4e204543bd1b Mon Sep 17 00:00:00 2001 From: Vizit0r Date: Thu, 22 Aug 2019 16:01:05 +0300 Subject: [PATCH] 1)InvokeCall added, instead of all different callers (x86, x64, powerpc etc) for Delphi 2010+. Tested on Win x86&x64, Android, MacOS32 - no problems observed. 2) Changes for correct MACOS compilation in Delphi 3) few changes and fixes for correct work on D7. --- Source/InvokeCall.inc | 185 ++++++++++++++++++++++++++++++++++++++++ Source/uPSComponent.pas | 9 +- Source/uPSDebugger.pas | 2 +- Source/uPSRuntime.pas | 44 ++++++---- Source/uPSUtils.pas | 1 + 5 files changed, 224 insertions(+), 17 deletions(-) create mode 100644 Source/InvokeCall.inc diff --git a/Source/InvokeCall.inc b/Source/InvokeCall.inc new file mode 100644 index 00000000..f727680f --- /dev/null +++ b/Source/InvokeCall.inc @@ -0,0 +1,185 @@ +function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean; +var SysCalConv : TCallConv; + Args: TArray; + Arg : TValue; + i : Integer; + fvar: PPSVariantIFC; + IsConstr : Boolean; + ctx: TRTTIContext; + RttiType : TRttiType; + ResValue : TValue; +begin + Result := False; + case CallingConv of + cdRegister : SysCalConv := ccReg; + cdPascal : SysCalConv := ccPascal; + cdCdecl : SysCalConv := ccCdecl; + cdStdCall : SysCalConv := ccStdCall; + cdSafeCall : SysCalConv := ccSafeCall; + else + SysCalConv := ccReg;//to prevent warning "W1036 Variable might not have been initialized" + end; + + if Assigned(_Self) then + Args := Args + [TValue.From( _Self )]; + + for I := 0 to Params.Count - 1 do + begin + if Params[i] = nil + then Exit; + fvar := Params[i]; + + if fvar.varparam then + begin { var param } + case fvar.aType.BaseType of + btArray, btVariant, btSet, btStaticArray, btRecord, btInterface, btClass, {$IFNDEF PS_NOWIDESTRING} btWideString, btWideChar, {$ENDIF} + btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency, + btUnicodeString + {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: + Arg := TValue.From( Pointer(fvar.dta) ); + else + begin + Exit; + end; + end; + end + else + begin { not a var param } + case fvar.aType.BaseType of + { add normal params here } + {$IFNDEF PS_NOWIDESTRING} + btWidestring, + btUnicodestring, + {$ENDIF} + btString: Arg := TValue.From(pstring(fvar.dta)^); + btU8, btS8: Arg := TValue.From(pbyte(fvar.dta)^); + btU16, BtS16: Arg := TValue.From(pword(fvar.dta)^); + btU32, btS32: Arg := TValue.From(pCardinal(fvar.dta)^); + {$IFNDEF PS_NOINT64}bts64:{$ENDIF} Arg := TValue.From(pint64(fvar.dta)^); + btSingle: Arg := TValue.From(PSingle(fvar.dta)^); + btDouble, btExtended: Arg := TValue.From(PDouble(fvar.dta)^); + btPChar: Arg := TValue.From(ppchar(fvar.dta)^); + btChar: Arg := TValue.From(pchar(fvar.dta)^); + btClass: Arg := TValue.From(TObject(fvar.dta^)); + btRecord: Arg := TValue.From(fvar.dta); + btStaticArray: Arg := TValue.From(fvar.dta); + btArray: + begin + if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then + begin //openarray + //in case of openarray we should provide TWO params: first is pointer to array, + Args := Args + [TValue.From(Pointer(fvar.Dta^))]; + //2nd - integer with arraylength - 1 (high) + Arg := TValue.From(PSDynArrayGetLength(Pointer(fvar.Dta^), fvar.aType)-1);// = High of OpenArray + end + else //dynarray = just push pointer + Arg := TValue.From(fvar.dta); + end; + btSet: + begin + case TPSTypeRec_Set(fvar.aType).aByteSize of + 1: Arg := TValue.From(pbyte(fvar.dta)^); + 2: Arg := TValue.From(pWord(fvar.dta)^); + 3, + 4: Arg := TValue.From(pCardinal(fvar.dta)^); + else + Arg := TValue.From(fvar.dta); + end; + end; + else +// writeln(stderr, 'Parameter type not implemented!'); + Exit; + end; { case } + end; + Args := Args + [Arg]; + end; + + IsConstr := (Integer(CallingConv) and 64) <> 0; + if not assigned(res) then + begin + Invoke(Address,Args,SysCalConv,nil,False,IsConstr); { ignore return } + end + else begin + case res.atype.basetype of + { add result types here } + btString: tbtstring(res.dta^) := tbtstring(Invoke(Address,Args,SysCalConv,TypeInfo(String),False,IsConstr).AsString) + ; + {$IFNDEF PS_NOWIDESTRING} + btUnicodeString: tbtunicodestring(res.dta^) := Invoke(Address,Args,SysCalConv,TypeInfo(String),False,IsConstr).AsString; + btWideString: tbtWideString(res.dta^) := Invoke(Address,Args,SysCalConv,TypeInfo(String),False,IsConstr).AsString; + {$ENDIF} + btU8, btS8: pbyte(res.dta)^ := Byte(Invoke(Address,Args,SysCalConv,TypeInfo(Byte),False,IsConstr).AsInteger); + btU16, btS16: pword(res.dta)^ := word(Invoke(Address,Args,SysCalConv,TypeInfo(Word),False,IsConstr).AsInteger); + btU32, btS32: pCardinal(res.dta)^ := Cardinal(Invoke(Address,Args,SysCalConv,TypeInfo(Cardinal),False,IsConstr).AsInteger); + {$IFNDEF PS_NOINT64}bts64:{$ENDIF} pInt64(res.dta)^ := Int64(Invoke(Address,Args,SysCalConv,TypeInfo(Int64),False,IsConstr).AsInt64); + btSingle: psingle(res.dta)^ := Double(Invoke(Address,Args,SysCalConv,TypeInfo(Single),False,IsConstr).AsExtended); + btDouble, btExtended: pdouble(res.dta)^ := Double(Invoke(Address,Args,SysCalConv,TypeInfo(Double),False,IsConstr).AsExtended); + btPChar: ppchar(res.dta)^ := pchar(Invoke(Address,Args,SysCalConv,TypeInfo(PChar),False,IsConstr).AsType()); + btChar: pchar(res.dta)^ := Char(Invoke(Address,Args,SysCalConv,TypeInfo(Char),False,IsConstr).AsType()); + btSet: + begin + case TPSTypeRec_Set(res.aType).aByteSize of + 1: byte(res.Dta^) := Byte(Invoke(Address,Args,SysCalConv,TypeInfo(Byte),False,IsConstr).AsInteger); + 2: word(res.Dta^) := word(Invoke(Address,Args,SysCalConv,TypeInfo(Word),False,IsConstr).AsInteger); + 3, + 4: Longint(res.Dta^) := Cardinal(Invoke(Address,Args,SysCalConv,TypeInfo(Cardinal),False,IsConstr).AsInteger); + else + begin + for RttiType in ctx.GetTypes do + if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkSet) + and (RttiType.TypeSize = TPSTypeRec_Set(res.aType).aByteSize) then + begin + Invoke(Address,Args,SysCalConv,RttiType.Handle,False,IsConstr).ExtractRawData(res.dta); + Break; + end; + end; + end; + end; + btClass: + begin + for RttiType in ctx.GetTypes do + if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkClass) then + begin + TObject(res.dta^) := Invoke(Address,Args,SysCalConv,RttiType.Handle,False,IsConstr).AsObject; + Break; + end; + end; + btStaticArray: + begin + for RttiType in ctx.GetTypes do + if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkArray) then + begin + CopyArrayContents(res.dta, Invoke(Address,Args,SysCalConv,RttiType.Handle,False,IsConstr).GetReferenceToRawData, TPSTypeRec_StaticArray(res.aType).Size, TPSTypeRec_StaticArray(res.aType).ArrayType); + Break; + end; + end; + btRecord: + begin + for RttiType in ctx.GetTypes do + if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkRecord) then + begin + CopyArrayContents(res.dta, (Invoke(Address,Args,SysCalConv,RttiType.Handle,False,IsConstr).GetReferenceToRawData), 1, res.aType); + Break; + end; + end; + btArray: //need to check with open arrays + begin + for RttiType in ctx.GetTypes do + if (RttiType.Name.ToUpper.EndsWith(String(res.aType.FExportName))) and (RttiType.TypeKind = tkDynArray) then + begin + ResValue := Invoke(Address,Args,SysCalConv,RttiType.Handle,False,IsConstr); + if ResValue.GetArrayLength > 0 then + CopyArrayContents(res.dta, ResValue.GetReferenceToRawData, 1, res.aType) + else + res.dta := nil; + Break; + end; + end; + else +// writeln(stderr, 'Result type not implemented!'); + Exit; + end; { case } + end; //assigned(res) + + Result := True; +end; diff --git a/Source/uPSComponent.pas b/Source/uPSComponent.pas index 2c60cfc1..6b906c96 100644 --- a/Source/uPSComponent.pas +++ b/Source/uPSComponent.pas @@ -4,7 +4,9 @@ interface uses SysUtils, Classes, uPSRuntime, uPSDebugger, uPSUtils, - uPSCompiler, uPSC_dll, uPSR_dll, uPSPreProcessor; + uPSCompiler, + {$IF DEFINED (MSWINDOWS) OR Defined (UNIX) OR Defined (fpc)} uPSC_dll, uPSR_dll,{$IFEND} + uPSPreProcessor; const {alias to @link(ifps3.cdRegister)} @@ -1147,12 +1149,17 @@ procedure TPSScript.DoOnSetNotificationVariant(const Name: tbtstring; procedure TPSDllPlugin.CompOnUses; begin + CompExec.Comp.OnExternalProc := nil; + {$IF DEFINED (MSWINDOWS) OR Defined (UNIX) OR Defined (fpc)} CompExec.Comp.OnExternalProc := DllExternalProc; + {$IFEND} end; procedure TPSDllPlugin.ExecOnUses; begin + {$IF DEFINED (MSWINDOWS) OR Defined (UNIX) OR Defined (fpc)} RegisterDLLRuntime(CompExec.Exec); + {$IFEND} end; diff --git a/Source/uPSDebugger.pas b/Source/uPSDebugger.pas index be85699c..81fd9f11 100644 --- a/Source/uPSDebugger.pas +++ b/Source/uPSDebugger.pas @@ -531,7 +531,7 @@ function TPSCustomDebugExec.GetCallStack(var Count: Cardinal): tbtString; else Result:= Result + ParamList.Items[I] + ': ' + PSVariantToString(NewTPSVariantIFC(FStack[Cardinal(Longint(StackBase) - Longint(I) - 1)], False), '') + '; '; - Result := tbtString(String(Result).Remove(Length(Result)-2)); + // Result := tbtString(String(Result).Remove(Length(Result)-2)); end; var diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index fb05370c..5a9f70c5 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -9,7 +9,9 @@ interface uses - SysUtils, uPSUtils{$IFDEF DELPHI6UP}, variants{$ENDIF}{$IFDEF MACOS},uPSCMac{$ELSE}{$IFNDEF PS_NOIDISPATCH}{$IFDEF DELPHI3UP}, ActiveX, Windows{$ELSE}, Ole2{$ENDIF}{$ENDIF}{$ENDIF}; + {$IFNDEF FPC} {$IFDEF DELPHI2010UP} System.Rtti,{$ENDIF} {$ENDIF} + SysUtils, uPSUtils{$IFDEF DELPHI6UP}, variants{$ENDIF} + {$IFNDEF PS_NOIDISPATCH}{$IFDEF DELPHI3UP}, ActiveX, Windows{$ELSE}, Ole2{$ENDIF}{$ENDIF}; type @@ -1101,7 +1103,10 @@ function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtS implementation uses - TypInfo {$IFDEF DELPHI3UP}{$IFNDEF FPC}{$IFNDEF KYLIX} , ComObj {$ENDIF}{$ENDIF}{$ENDIF}{$IFDEF PS_FPC_HAS_COM}, ComObj{$ENDIF} {$IFDEF DELPHI_TOKYO_UP}, AnsiStrings{$ENDIF}; + TypInfo {$IFDEF DELPHI3UP} + {$IFNDEF FPC}{$IFDEF MSWINDOWS} , ComObj {$ENDIF}{$ENDIF}{$ENDIF} + {$IFDEF PS_FPC_HAS_COM}, ComObj{$ENDIF} + {$IF NOT DEFINED (NEXTGEN) AND NOT DEFINED (MACOS) AND DEFINED (DELPHI_TOKYO_UP)}, AnsiStrings{$IFEND}; {$IFDEF DELPHI3UP } resourceString @@ -3534,9 +3539,9 @@ function PSGetAnsiChar(Src: Pointer; aType: TPSTypeRec): tbtchar; begin Res := PSGetAnsiString(Src,aType); if Length(Res) > 0 then - Result := Res[Low(Res)] + Result := Res[{$IFDEF DELPHI2009UP}Low(Res){$ELSE}1{$ENDIF}] else - Exit(#0); + Result := #0; end; function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString; @@ -9450,7 +9455,8 @@ procedure TPSExec.RegisterStandardProcs; function ToString(p: PansiChar): tbtString; begin - SetString(Result, p, {$IFDEF DELPHI_TOKYO_UP}AnsiStrings.{$ENDIF}StrLen(p)); + SetString(Result, p, + {$IF NOT DEFINED (NEXTGEN) AND NOT DEFINED (MACOS) AND DEFINED (DELPHI_TOKYO_UP)}AnsiStrings.StrLen(p){$ELSE}Length(p){$IFEND}); end; function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Variant): Boolean; @@ -9834,16 +9840,24 @@ procedure DestroyOpenArray(Sender: TPSExec; V: POpenArray); {$ifndef FPC} -{$IFDEF Delphi6UP} - {$IFDEF CPUX64} - {$include x64.inc} + {$IFDEF DELPHI2010UP} + {$IFDEF AUTOREFCOUNT} + {$fatal Pascal Script does not supports compilation with AUTOREFCOUNT at the moment!} + {$ELSE} + {$include InvokeCall.inc} + {$ENDIF} {$ELSE} - {$include x86.inc} + {$IFDEF Delphi6UP} + {$IFDEF CPUX64} + {$include x64.inc} + {$ELSE} + {$include x86.inc} + {$ENDIF} + {$ELSE} + {$include x86.inc} + {$ENDIF} {$ENDIF} -{$ELSE} - {$include x86.inc} -{$ENDIF} -{$else} +{$else} //fpc includes left unchanged. {$IFDEF Delphi6UP} {$if defined(cpu86)} {$include x86.inc} @@ -9857,7 +9871,7 @@ procedure DestroyOpenArray(Sender: TPSExec; V: POpenArray); {$fatal Pascal Script is not supported for your architecture at the moment!} {$ifend} {$ELSE} -{$include x86.inc} + {$include x86.inc} {$ENDIF} {$endif} @@ -10395,7 +10409,7 @@ function ClassCallProcVirtualConstructor(Caller: TPSExec; p: TPSExternalProcRec; v := NewPPSVariantIFC(Stack[CurrStack + 1], True); end else v := nil; try - Result := Caller.InnerfuseCall(FSelf, VirtualClassMethodPtrToPtr(p.Ext1, FSelf), {$IFDEF FPC}TPSCallingConvention(Integer(cc) or 128){$ELSE}cc{$ENDIF}, MyList, v); + Result := Caller.InnerfuseCall(FSelf, VirtualClassMethodPtrToPtr(p.Ext1, FSelf), TPSCallingConvention(Integer(cc) or 128), MyList, v); finally DisposePPSVariantIFC(v); DisposePPSVariantIFCList(mylist); diff --git a/Source/uPSUtils.pas b/Source/uPSUtils.pas index 27bd8bb7..477d2ae7 100644 --- a/Source/uPSUtils.pas +++ b/Source/uPSUtils.pas @@ -1734,3 +1734,4 @@ procedure TPSUnit.SetUnitName(const Value: TbtString); end. +