Delphi/pascalscript
Delphi/pascalscript
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

1)InvokeCall added, instead of all different callers (x86, x64, powerpc etc) for Delphi 2010+. (#207)

Browse Source 
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.
This commit is contained in:
Vizit0r 2019-08-26 07:49:56 +03:00 committed by Carlo Kok
parent 51a015cbc5
commit 86a057c868
5 changed files with 224 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

185
Source/InvokeCall.inc Normal file
View File

@ -0,0 +1,185 @@
function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
var SysCalConv : TCallConv;
Args: TArray<TValue>;
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<Pointer>( _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>( 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<Pointer>(fvar.dta);
btStaticArray: Arg := TValue.From<Pointer>(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>(Pointer(fvar.Dta^))];
//2nd - integer with arraylength - 1 (high)
Arg := TValue.From<Integer>(PSDynArrayGetLength(Pointer(fvar.Dta^), fvar.aType)-1);// = High of OpenArray
end
else //dynarray = just push pointer
Arg := TValue.From<Pointer>(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<Pointer>(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<PChar>());
btChar: pchar(res.dta)^ := Char(Invoke(Address,Args,SysCalConv,TypeInfo(Char),False,IsConstr).AsType<Char>());
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;

9
Source/uPSComponent.pas
View File

@ -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 @@ end;
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;

2
Source/uPSDebugger.pas
View File

@ -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

44
Source/uPSRuntime.pas
View File

@ -9,7 +9,9 @@ Copyright (C) 2000-2009 by Carlo Kok (ck@carlo-kok.com)
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 @@ var Res : tbtString;
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 @@ end;
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 @@ end;
{$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 @@ end;
{$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 @@ begin
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);

1
Source/uPSUtils.pas
View File

@ -1734,3 +1734,4 @@ end;
end.