Skip to content

1) Delphi methods calling fully rewritten to Invoke calling. Works on… #203

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 1 commit into from
Closed

1) Delphi methods calling fully rewritten to Invoke calling. Works on… #203

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
182 changes: 182 additions & 0 deletions Source/InvokeCall.inc
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,182 @@
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) ); { TODO: test all }
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); //works
btStaticArray: Arg := TValue.From<Pointer>(fvar.dta); //works
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 send 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^) := 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(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(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(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(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(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;
{ TODO add and test: btInterface }
else
// writeln(stderr, 'Result type not implemented!');
Exit;
end; { case }
end; //assigned(res)

Result := True;
end;
1 change: 0 additions & 1 deletion Source/uPSC_dateutils.pas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -27,7 +27,6 @@ procedure RegisterDatetimeLibrary_C(S: TPSPascalCompiler);
s.AddDelphiFunction('function UnixToDateTime(U: Int64): TDateTime;');

s.AddDelphiFunction('function DateToStr(D: TDateTime): string;');
s.AddDelphiFunction('function StrToDate(const S: string): TDateTime;');
s.AddDelphiFunction('function FormatDateTime(const fmt: string; D: TDateTime): string;');
end;

Expand Down
Loading