git-svn-id: http://code.remobjects.com/svn/pascalscript@41 5c9d2617-0215-0410-a2ee-e80e04d1c6d8
This commit is contained in:
carlokok
parent
3cf2d55ec7
commit
04eb8eb428
@ -1,4 +1,5 @@
|
||||
Nov 2007
|
||||
- Power pc support (done by Henry Vermaak)
|
||||
- 0004558: Re: Exception problem
|
||||
Oct 2007
|
||||
- 0004504: Getting characters at a given position
|
||||
|
||||
338
Source/powerpc.inc
Normal file
338
Source/powerpc.inc
Normal file
@ -0,0 +1,338 @@
|
||||
{ implementation of the powerpc osx abi for function calls in pascal script
|
||||
Copyright (c) 2007 by Henry Vermaak (henry.vermaak@gmail.com) }
|
||||
|
||||
{$ifndef darwin}
|
||||
{$fatal This code is Darwin specific at the moment!}
|
||||
{$endif}
|
||||
|
||||
{$ifndef cpu32}
|
||||
{$fatal This code is 32bit specific at the moment!}
|
||||
{$endif}
|
||||
|
||||
const
|
||||
rtINT = 0;
|
||||
rtINT64 = 1;
|
||||
rtFLOAT = 2;
|
||||
|
||||
type
|
||||
Trint = array[1..8] of dword;
|
||||
Trfloat = array[1..13] of double;
|
||||
|
||||
{$goto on}
|
||||
{ define labels }
|
||||
label
|
||||
rfloat_loop,
|
||||
stack_loop,
|
||||
load_regs,
|
||||
int_result,
|
||||
int64_result,
|
||||
float_result,
|
||||
asmcall_end;
|
||||
|
||||
{ call a function from a pointer }
|
||||
{ resulttype: 0 = int, 1 = int64, 2 = float }
|
||||
function ppcasmcall(rint: Trint; rfloat: Trfloat; proc, stack: pointer; stacksize, resulttype: integer): pointer; assembler; nostackframe;
|
||||
asm
|
||||
mflr r0
|
||||
stw r0, 8(r1)
|
||||
|
||||
{ save non-volatile register/s - make sure the stack size is sufficient! }
|
||||
stw r31, -4(r1) { stacksize }
|
||||
|
||||
stwu r1, -240(r1) { create stack }
|
||||
|
||||
{ get all the params into the stack }
|
||||
stw r3, 48(r1) { rint }
|
||||
stw r4, 52(r1) { rfloat }
|
||||
stw r5, 56(r1) { proc }
|
||||
stw r6, 60(r1) { stack }
|
||||
stw r7, 64(r1) { stacksize }
|
||||
stw r8, 68(r1) { resulttype }
|
||||
{ result is stored in 72(r1) and 76(r1) (if returning int64) }
|
||||
|
||||
{ write rint array into stack }
|
||||
lwz r2, 48(r1) { rint }
|
||||
lfd f0, 0(r2)
|
||||
stfd f0, 80(r1) { rint[1], rint[2] }
|
||||
lfd f0, 8(r2)
|
||||
stfd f0, 88(r1) { rint[3], rint[4] }
|
||||
lfd f0, 16(r2)
|
||||
stfd f0, 96(r1) { rint[5], rint[6] }
|
||||
lfd f0, 24(r2)
|
||||
stfd f0, 104(r1) { rint[7], rint[8] }
|
||||
|
||||
{ write rfloat array into stack }
|
||||
lwz r2, 52(r1) { rfloat }
|
||||
addi r4, r1, 112 { rfloat[1] from here upwards (8 bytes apart) }
|
||||
subi r2, r2, 8 { src }
|
||||
subi r4, r4, 8 { dest }
|
||||
li r3, 13 { counter }
|
||||
|
||||
rfloat_loop:
|
||||
subic. r3, r3, 1 { dec counter }
|
||||
lfdu f0, 8(r2) { load rfloat[x] + update }
|
||||
stfdu f0, 8(r4) { store rfloat[x] + update }
|
||||
bne cr0, rfloat_loop
|
||||
|
||||
{ create new stack }
|
||||
mflr r0
|
||||
stw r0, 8(r1)
|
||||
mr r12, r1 { remember previous stack to fill in regs later }
|
||||
|
||||
lwz r31, 64(r12) { load stacksize into r31 }
|
||||
neg r3, r31 { negate }
|
||||
stwux r1, r1, r3 { create new stack }
|
||||
|
||||
{ build up the stack here }
|
||||
mr r3, r31 { counter }
|
||||
subic. r3, r3, 24 { don't write first 24 }
|
||||
blt cr0, load_regs { don't fill in stack if there is none }
|
||||
|
||||
lwz r2, 60(r12) { pointer to stack }
|
||||
addi r2, r2, 24 { start of params }
|
||||
subi r2, r2, 1 { src }
|
||||
|
||||
addi r4, r1, 24 { start of params }
|
||||
subi r4, r4, 1 { dest }
|
||||
|
||||
stack_loop:
|
||||
subic. r3, r3, 1 { dec counter }
|
||||
lbzu r5, 1(r2) { load stack + update }
|
||||
stbu r5, 1(r4) { store stack + update }
|
||||
bne cr0, stack_loop
|
||||
|
||||
load_regs: { now load the registers from the previous stack in r12 }
|
||||
lwz r3, 80(r12)
|
||||
lwz r4, 84(r12)
|
||||
lwz r5, 88(r12)
|
||||
lwz r6, 92(r12)
|
||||
lwz r7, 96(r12)
|
||||
lwz r8, 100(r12)
|
||||
lwz r9, 104(r12)
|
||||
lwz r10, 108(r12)
|
||||
|
||||
lfd f1, 112(r12)
|
||||
lfd f2, 120(r12)
|
||||
lfd f3, 128(r12)
|
||||
lfd f4, 136(r12)
|
||||
lfd f5, 144(r12)
|
||||
lfd f6, 152(r12)
|
||||
lfd f7, 160(r12)
|
||||
lfd f8, 168(r12)
|
||||
lfd f9, 176(r12)
|
||||
lfd f10, 184(r12)
|
||||
lfd f11, 192(r12)
|
||||
lfd f12, 200(r12)
|
||||
lfd f13, 208(r12)
|
||||
|
||||
{ now call this function }
|
||||
lwz r2, 56(r12) { proc }
|
||||
mtctr r2 { move to ctr }
|
||||
bctrl { branch and link to ctr }
|
||||
|
||||
{ restore stack - use stacksize in r31 }
|
||||
add r1, r1, r31
|
||||
lwz r0, 8(r1)
|
||||
mtlr r0
|
||||
|
||||
{ check resulttype and put appropriate pointer into r3 }
|
||||
lwz r2, 68(r1) { resulttype }
|
||||
cmpwi cr0, r2, 0 { int result? }
|
||||
beq cr0, int_result { branch if equal }
|
||||
|
||||
cmpwi cr0, r2, 1 { single result? }
|
||||
beq cr0, int64_result { branch if equal }
|
||||
|
||||
|
||||
float_result: { the result is a double}
|
||||
stfd f1, 72(r1) { write f1 to result on stack }
|
||||
b asmcall_end
|
||||
|
||||
|
||||
int64_result: { the result is a single }
|
||||
stw r3, 72(r1) { write high dword to result on stack }
|
||||
stw r4, 76(r1) { write low dword to result on stack }
|
||||
b asmcall_end
|
||||
|
||||
|
||||
int_result: { the result is dword }
|
||||
stw r3, 72(r1) { write r3 to result on stack }
|
||||
|
||||
|
||||
asmcall_end: { epilogue }
|
||||
addi r3, r1, 72 { pointer to result on the stack }
|
||||
addi r1, r1, 240 { restore stack }
|
||||
|
||||
{ restore non-volatile register/s }
|
||||
lwz r31, -4(r1)
|
||||
|
||||
lwz r0, 8(r1)
|
||||
mtlr r0
|
||||
blr
|
||||
end;
|
||||
|
||||
function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
|
||||
var
|
||||
rint: Trint; { registers r3 to r10 }
|
||||
rfloat: Trfloat; { registers f1 to f13 }
|
||||
st: packed array of byte; { stack }
|
||||
i, j, rindex, findex, stindex: integer;
|
||||
fvar: PPSVariantIFC;
|
||||
|
||||
{ add a dword to stack }
|
||||
procedure addstackdword(value: dword);
|
||||
begin
|
||||
setlength(st, stindex+4);
|
||||
pdword(@st[stindex])^ := value;
|
||||
inc(stindex, 4);
|
||||
end;
|
||||
|
||||
{ add a float to stack }
|
||||
procedure addstackfloat(value: pointer; size: integer);
|
||||
begin
|
||||
setlength(st, stindex + (size * 4));
|
||||
if size = 1
|
||||
then psingle(@st[stindex])^ := single(value^)
|
||||
else pdouble(@st[stindex])^ := double(value^);
|
||||
inc(stindex, size*4);
|
||||
end;
|
||||
|
||||
{ add to the general registers or overflow to stack }
|
||||
procedure addgen(value: dword);
|
||||
begin
|
||||
if rindex <= 8
|
||||
then begin
|
||||
rint[rindex] := value;
|
||||
inc(rindex);
|
||||
addstackdword(value);
|
||||
end
|
||||
else begin
|
||||
addstackdword(value);
|
||||
end;
|
||||
end;
|
||||
{ add to the float registers or overflow to stack }
|
||||
{ size = 1 for single, 2 for double }
|
||||
procedure addfloat(value: pointer; size: integer);
|
||||
begin
|
||||
if findex <= 13
|
||||
then begin
|
||||
if size = 1
|
||||
then rfloat[findex] := single(value^)
|
||||
else rfloat[findex] := double(value^);
|
||||
inc(findex);
|
||||
inc(rindex, size);
|
||||
addstackfloat(value, size);
|
||||
end
|
||||
else begin
|
||||
addstackfloat(value, size);
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
rindex := 1;
|
||||
findex := 1;
|
||||
stindex := 24;
|
||||
setlength(st, stindex);
|
||||
Result := False;
|
||||
|
||||
{ the pointer of the result needs to be passed first in the case of some result types }
|
||||
if assigned(res)
|
||||
then begin
|
||||
case res.atype.basetype of
|
||||
btStaticArray, btRecord: addgen(dword(res.dta));
|
||||
end;
|
||||
end;
|
||||
|
||||
{ process all parameters }
|
||||
for i := 0 to Params.Count-1 do begin
|
||||
if Params[i] = nil
|
||||
then Exit;
|
||||
fvar := Params[i];
|
||||
|
||||
{ cook dynamic arrays - fpc stores size-1 at @array-4 }
|
||||
if (fvar.aType.BaseType = btArray)
|
||||
then dec(pdword(pointer(fvar.dta^)-4)^);
|
||||
|
||||
if fvar.varparam
|
||||
then begin { var param }
|
||||
case fvar.aType.BaseType of
|
||||
{ add var params here }
|
||||
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
|
||||
{$IFNDEF PS_NOINT64}, bts64{$ENDIF}: addgen(dword(fvar.dta)); { TODO: test all }
|
||||
else begin
|
||||
writeln(stderr, 'Parameter type not recognised!');
|
||||
Exit;
|
||||
end;
|
||||
end; { case }
|
||||
end else begin { not a 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
|
||||
// {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: writeln('normal param');
|
||||
|
||||
{ add normal params here }
|
||||
btString: addgen(dword(pstring(fvar.dta)^));
|
||||
btU8, btS8: addgen(dword(pbyte(fvar.dta)^));
|
||||
btU16, BtS16: addgen(dword(pword(fvar.dta)^));
|
||||
btU32, btS32: addgen(dword(pdword(fvar.dta)^));
|
||||
btSingle: addfloat(fvar.dta, 1);
|
||||
btDouble, btExtended: addfloat(fvar.dta, 2);
|
||||
btPChar: addgen(dword(ppchar(fvar.dta)^));
|
||||
btChar: addgen(dword(pchar(fvar.dta)^));
|
||||
{$IFNDEF PS_NOINT64}bts64:{$ENDIF} begin
|
||||
addgen(dword(pint64(fvar.dta)^ shr 32));
|
||||
addgen(dword(pint64(fvar.dta)^ and $ffffffff));
|
||||
end;
|
||||
btStaticArray: addgen(dword(fvar.dta));
|
||||
btRecord: for j := 0 to (fvar.atype.realsize div 4)-1 do
|
||||
addgen(pdword(fvar.dta + j*4)^);
|
||||
btArray: addgen(dword(fvar.dta^));
|
||||
|
||||
{ TODO add and test }
|
||||
{ btVariant, btSet, btInterface, btClass }
|
||||
|
||||
else begin
|
||||
writeln(stderr, 'Parameter type not implemented!');
|
||||
Exit;
|
||||
end;
|
||||
end; { case }
|
||||
end; { else }
|
||||
end; { for }
|
||||
|
||||
if not assigned(res)
|
||||
then begin
|
||||
ppcasmcall(rint, rfloat, address, st, stindex, rtINT); { ignore return }
|
||||
end
|
||||
else begin
|
||||
case res.atype.basetype of
|
||||
{ add result types here }
|
||||
btString: pstring(res.dta)^ := pstring(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^;
|
||||
btU8, btS8: pbyte(res.dta)^ := byte(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
|
||||
btU16, btS16: pword(res.dta)^ := word(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
|
||||
btU32, btS32: pdword(res.dta)^ := pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^;
|
||||
btSingle: psingle(res.dta)^ := pdouble(ppcasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
|
||||
btDouble, btExtended: pdouble(res.dta)^ := pdouble(ppcasmcall(rint, rfloat, address, st, stindex, rtFLOAT))^;
|
||||
btPChar: ppchar(res.dta)^ := pchar(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
|
||||
btChar: pchar(res.dta)^ := char(pdword(ppcasmcall(rint, rfloat, address, st, stindex, rtINT))^);
|
||||
btStaticArray, btRecord: ppcasmcall(rint, rfloat, address, st, stindex, rtINT);
|
||||
btArray: res.dta := ppcasmcall(rint, rfloat, address, st, stindex, rtINT);
|
||||
|
||||
{ TODO add and test }
|
||||
|
||||
else begin
|
||||
writeln(stderr, 'Result type not implemented!');
|
||||
exit;
|
||||
end; { else }
|
||||
end; { case }
|
||||
end;
|
||||
|
||||
{ cook dynamic arrays - fpc stores size-1 at @array-4 }
|
||||
for i := 0 to Params.Count-1 do begin
|
||||
fvar := Params[i];
|
||||
if (fvar.aType.BaseType = btArray)
|
||||
then inc(pdword(pointer(fvar.dta^)-4)^);
|
||||
end;
|
||||
|
||||
Result := True;
|
||||
end;
|
||||
@ -1815,6 +1815,9 @@ begin
|
||||
end;
|
||||
|
||||
procedure BlockWriteVariant(BlockInfo: TPSBlockInfo; p: PIfRVariant);
|
||||
var
|
||||
du8: tbtu8;
|
||||
du16: tbtu16;
|
||||
begin
|
||||
BlockWriteLong(BlockInfo, p^.FType.FinalTypeNo);
|
||||
case p.FType.BaseType of
|
||||
@ -1841,15 +1844,20 @@ begin
|
||||
BlockWriteLong(BlockInfo, Length(tbtString(p^.tstring)));
|
||||
BlockWriteData(BlockInfo, tbtString(p^.tstring)[1], Length(tbtString(p^.tstring)));
|
||||
end;
|
||||
btenum:
|
||||
begin
|
||||
if TPSEnumType(p^.FType).HighValue <=256 then
|
||||
BlockWriteData(BlockInfo, p^.tu32, 1)
|
||||
else if TPSEnumType(p^.FType).HighValue <=65536 then
|
||||
BlockWriteData(BlockInfo, p^.tu32, 2)
|
||||
else
|
||||
BlockWriteData(BlockInfo, p^.tu32, 4);
|
||||
end;
|
||||
btenum:
|
||||
begin
|
||||
if TPSEnumType(p^.FType).HighValue <=256 then
|
||||
begin
|
||||
du8 := tbtu8(p^.tu32);
|
||||
BlockWriteData(BlockInfo, du8, 1)
|
||||
end
|
||||
else if TPSEnumType(p^.FType).HighValue <=65536 then
|
||||
begin
|
||||
du16 := tbtu16(p^.tu32);
|
||||
BlockWriteData(BlockInfo, du16, 2)
|
||||
end;
|
||||
end;
|
||||
|
||||
bts8,btu8: BlockWriteData(BlockInfo, p^.tu8, 1);
|
||||
bts16,btu16: BlockWriteData(BlockInfo, p^.tu16, 2);
|
||||
bts32,btu32: BlockWriteData(BlockInfo, p^.tu32, 4);
|
||||
@ -2272,7 +2280,7 @@ type
|
||||
|
||||
function PS_mi2s(i: Cardinal): string;
|
||||
begin
|
||||
Result := #0#0#0#0;
|
||||
SetLength(Result, 4);
|
||||
Cardinal((@Result[1])^) := i;
|
||||
end;
|
||||
|
||||
|
||||
@ -8614,247 +8614,6 @@ begin
|
||||
RegisterInterfaceLibraryRuntime(Self);
|
||||
end;
|
||||
|
||||
function RealFloatCall_Register(p: Pointer;
|
||||
_EAX, _EDX, _ECX: Cardinal;
|
||||
StackData: Pointer;
|
||||
StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
|
||||
): Extended; Stdcall; // make sure all things are on stack
|
||||
var
|
||||
E: Extended;
|
||||
begin
|
||||
asm
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
mov eax, stackdata
|
||||
@@1:
|
||||
mov edx, [eax]
|
||||
push edx
|
||||
sub eax, 4
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@1
|
||||
@@2:
|
||||
mov eax,_EAX
|
||||
mov edx,_EDX
|
||||
mov ecx,_ECX
|
||||
call p
|
||||
fstp tbyte ptr [e]
|
||||
end;
|
||||
Result := E;
|
||||
end;
|
||||
|
||||
function RealFloatCall_Other(p: Pointer;
|
||||
StackData: Pointer;
|
||||
StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
|
||||
): Extended; Stdcall; // make sure all things are on stack
|
||||
var
|
||||
E: Extended;
|
||||
begin
|
||||
asm
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
mov eax, stackdata
|
||||
@@1:
|
||||
mov edx, [eax]
|
||||
push edx
|
||||
sub eax, 4
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@1
|
||||
@@2:
|
||||
call p
|
||||
fstp tbyte ptr [e]
|
||||
end;
|
||||
Result := E;
|
||||
end;
|
||||
|
||||
function RealFloatCall_CDecl(p: Pointer;
|
||||
StackData: Pointer;
|
||||
StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
|
||||
): Extended; Stdcall; // make sure all things are on stack
|
||||
var
|
||||
E: Extended;
|
||||
begin
|
||||
asm
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
mov eax, stackdata
|
||||
@@1:
|
||||
mov edx, [eax]
|
||||
push edx
|
||||
sub eax, 4
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@1
|
||||
@@2:
|
||||
call p
|
||||
fstp tbyte ptr [e]
|
||||
@@5:
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
@@6:
|
||||
pop edx
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@6
|
||||
end;
|
||||
Result := E;
|
||||
end;
|
||||
|
||||
function RealCall_Register(p: Pointer;
|
||||
_EAX, _EDX, _ECX: Cardinal;
|
||||
StackData: Pointer;
|
||||
StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
|
||||
ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
|
||||
var
|
||||
r: Longint;
|
||||
begin
|
||||
asm
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
mov eax, stackdata
|
||||
@@1:
|
||||
mov edx, [eax]
|
||||
push edx
|
||||
sub eax, 4
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@1
|
||||
@@2:
|
||||
mov eax,_EAX
|
||||
mov edx,_EDX
|
||||
mov ecx,_ECX
|
||||
call p
|
||||
mov ecx, resultlength
|
||||
cmp ecx, 0
|
||||
je @@5
|
||||
cmp ecx, 1
|
||||
je @@3
|
||||
cmp ecx, 2
|
||||
je @@4
|
||||
mov r, eax
|
||||
jmp @@5
|
||||
@@3:
|
||||
xor ecx, ecx
|
||||
mov cl, al
|
||||
mov r, ecx
|
||||
jmp @@5
|
||||
@@4:
|
||||
xor ecx, ecx
|
||||
mov cx, ax
|
||||
mov r, ecx
|
||||
@@5:
|
||||
mov ecx, resedx
|
||||
jecxz @@6
|
||||
mov [ecx], edx
|
||||
@@6:
|
||||
end;
|
||||
Result := r;
|
||||
end;
|
||||
|
||||
function RealCall_Other(p: Pointer;
|
||||
StackData: Pointer;
|
||||
StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
|
||||
ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
|
||||
var
|
||||
r: Longint;
|
||||
begin
|
||||
asm
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
mov eax, stackdata
|
||||
@@1:
|
||||
mov edx, [eax]
|
||||
push edx
|
||||
sub eax, 4
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@1
|
||||
@@2:
|
||||
call p
|
||||
mov ecx, resultlength
|
||||
cmp ecx, 0
|
||||
je @@5
|
||||
cmp ecx, 1
|
||||
je @@3
|
||||
cmp ecx, 2
|
||||
je @@4
|
||||
mov r, eax
|
||||
jmp @@5
|
||||
@@3:
|
||||
xor ecx, ecx
|
||||
mov cl, al
|
||||
mov r, ecx
|
||||
jmp @@5
|
||||
@@4:
|
||||
xor ecx, ecx
|
||||
mov cx, ax
|
||||
mov r, ecx
|
||||
@@5:
|
||||
mov ecx, resedx
|
||||
jecxz @@6
|
||||
mov [ecx], edx
|
||||
@@6:
|
||||
end;
|
||||
Result := r;
|
||||
end;
|
||||
|
||||
function RealCall_CDecl(p: Pointer;
|
||||
StackData: Pointer;
|
||||
StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
|
||||
ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
|
||||
var
|
||||
r: Longint;
|
||||
begin
|
||||
asm
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
mov eax, stackdata
|
||||
@@1:
|
||||
mov edx, [eax]
|
||||
push edx
|
||||
sub eax, 4
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@1
|
||||
@@2:
|
||||
call p
|
||||
mov ecx, resultlength
|
||||
cmp ecx, 0
|
||||
je @@5
|
||||
cmp ecx, 1
|
||||
je @@3
|
||||
cmp ecx, 2
|
||||
je @@4
|
||||
mov r, eax
|
||||
jmp @@5
|
||||
@@3:
|
||||
xor ecx, ecx
|
||||
mov cl, al
|
||||
mov r, ecx
|
||||
jmp @@5
|
||||
@@4:
|
||||
xor ecx, ecx
|
||||
mov cx, ax
|
||||
mov r, ecx
|
||||
@@5:
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@7
|
||||
@@6:
|
||||
pop eax
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@6
|
||||
mov ecx, resedx
|
||||
jecxz @@7
|
||||
mov [ecx], edx
|
||||
@@7:
|
||||
end;
|
||||
Result := r;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
|
||||
function ToString(p: PChar): string;
|
||||
begin
|
||||
@ -9218,469 +8977,17 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
EmptyPchar: array[0..0] of char = #0;
|
||||
|
||||
function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
|
||||
var
|
||||
Stack: ansistring;
|
||||
I: Longint;
|
||||
RegUsage: Byte;
|
||||
CallData: TPSList;
|
||||
pp: ^Byte;
|
||||
|
||||
EAX, EDX, ECX: Longint;
|
||||
|
||||
function rp(p: PPSVariantIFC): PPSVariantIFC;
|
||||
begin
|
||||
if p = nil then
|
||||
begin
|
||||
result := nil;
|
||||
exit;
|
||||
end;
|
||||
if p.aType.BaseType = btPointer then
|
||||
begin
|
||||
p^.aType := Pointer(Pointer(IPointer(p^.dta) + 4)^);
|
||||
p^.Dta := Pointer(p^.dta^);
|
||||
end;
|
||||
Result := p;
|
||||
end;
|
||||
|
||||
function GetPtr(fVar: PPSVariantIFC): Boolean;
|
||||
var
|
||||
varPtr: Pointer;
|
||||
UseReg: Boolean;
|
||||
tempstr: string;
|
||||
p: Pointer;
|
||||
begin
|
||||
Result := False;
|
||||
if FVar = nil then exit;
|
||||
if fVar.VarParam then
|
||||
begin
|
||||
case fvar.aType.BaseType of
|
||||
btArray:
|
||||
begin
|
||||
if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then
|
||||
begin
|
||||
p := CreateOpenArray(True, Self, FVar);
|
||||
if p = nil then exit;
|
||||
CallData.Add(p);
|
||||
case RegUsage of
|
||||
0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
|
||||
1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
|
||||
2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
|
||||
else begin
|
||||
Stack := #0#0#0#0 + Stack;
|
||||
Pointer((@Stack[1])^) := POpenArray(p)^.Data;
|
||||
end;
|
||||
end;
|
||||
case RegUsage of
|
||||
0: begin EAX := Longint(POpenArray(p)^.ItemCount - 1); Inc(RegUsage); end;
|
||||
1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
|
||||
2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
|
||||
else begin
|
||||
Stack := #0#0#0#0 + Stack;
|
||||
Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1;
|
||||
end;
|
||||
end;
|
||||
Result := True;
|
||||
Exit;
|
||||
end else begin
|
||||
{$IFDEF PS_DYNARRAY}
|
||||
varptr := fvar.Dta;
|
||||
{$ELSE}
|
||||
Exit;
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
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
|
||||
{$IFNDEF PS_NOINT64}, bts64{$ENDIF}:
|
||||
begin
|
||||
Varptr := fvar.Dta;
|
||||
end;
|
||||
else begin
|
||||
exit; //invalid type
|
||||
end;
|
||||
end; {case}
|
||||
case RegUsage of
|
||||
0: begin EAX := Longint(VarPtr); Inc(RegUsage); end;
|
||||
1: begin EDX := Longint(VarPtr); Inc(RegUsage); end;
|
||||
2: begin ECX := Longint(VarPtr); Inc(RegUsage); end;
|
||||
else begin
|
||||
Stack := #0#0#0#0 + Stack;
|
||||
Pointer((@Stack[1])^) := VarPtr;
|
||||
end;
|
||||
end;
|
||||
end else begin
|
||||
UseReg := True;
|
||||
case fVar^.aType.BaseType of
|
||||
btSet:
|
||||
begin
|
||||
tempstr := #0#0#0#0;
|
||||
case TPSTypeRec_Set(fvar.aType).aByteSize of
|
||||
1: Byte((@tempstr[1])^) := byte(fvar.dta^);
|
||||
2: word((@tempstr[1])^) := word(fvar.dta^);
|
||||
3, 4: cardinal((@tempstr[1])^) := cardinal(fvar.dta^);
|
||||
else
|
||||
pointer((@tempstr[1])^) := fvar.dta;
|
||||
end;
|
||||
end;
|
||||
btArray:
|
||||
begin
|
||||
if Copy(fvar^.aType.ExportName, 1, 10) = '!OPENARRAY' then
|
||||
begin
|
||||
p := CreateOpenArray(False, SElf, FVar);
|
||||
if p =nil then exit;
|
||||
CallData.Add(p);
|
||||
case RegUsage of
|
||||
0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
|
||||
1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
|
||||
2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
|
||||
else begin
|
||||
Stack := #0#0#0#0 + Stack;
|
||||
Pointer((@Stack[1])^) := POpenArray(p)^.Data;
|
||||
end;
|
||||
end;
|
||||
case RegUsage of
|
||||
0: begin EAX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
|
||||
1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
|
||||
2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
|
||||
else begin
|
||||
Stack := #0#0#0#0 + Stack;
|
||||
Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1;
|
||||
end;
|
||||
end;
|
||||
Result := True;
|
||||
exit;
|
||||
end else begin
|
||||
{$IFDEF PS_DYNARRAY}
|
||||
TempStr := #0#0#0#0;
|
||||
Pointer((@TempStr[1])^) := Pointer(fvar.Dta^);
|
||||
{$ELSE}
|
||||
Exit;
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
btVariant
|
||||
, btStaticArray, btRecord:
|
||||
begin
|
||||
TempStr := #0#0#0#0;
|
||||
Pointer((@TempStr[1])^) := Pointer(fvar.Dta);
|
||||
end;
|
||||
btDouble: {8 bytes} begin
|
||||
TempStr := #0#0#0#0#0#0#0#0;
|
||||
UseReg := False;
|
||||
double((@TempStr[1])^) := double(fvar.dta^);
|
||||
end;
|
||||
btCurrency: {8 bytes} begin
|
||||
TempStr := #0#0#0#0#0#0#0#0;
|
||||
UseReg := False;
|
||||
currency((@TempStr[1])^) := currency(fvar.dta^);
|
||||
end;
|
||||
btSingle: {4 bytes} begin
|
||||
TempStr := #0#0#0#0;
|
||||
UseReg := False;
|
||||
Single((@TempStr[1])^) := single(fvar.dta^);
|
||||
end;
|
||||
|
||||
btExtended: {10 bytes} begin
|
||||
UseReg := False;
|
||||
TempStr:= #0#0#0#0#0#0#0#0#0#0#0#0;
|
||||
Extended((@TempStr[1])^) := extended(fvar.dta^);
|
||||
end;
|
||||
btChar,
|
||||
btU8,
|
||||
btS8: begin
|
||||
TempStr := char(fVar^.dta^) + #0#0#0;
|
||||
end;
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}
|
||||
btu16, btS16: begin
|
||||
TempStr := #0#0#0#0;
|
||||
Word((@TempStr[1])^) := word(fVar^.dta^);
|
||||
end;
|
||||
btu32, bts32: begin
|
||||
TempStr := #0#0#0#0;
|
||||
Longint((@TempStr[1])^) := Longint(fVar^.dta^);
|
||||
end;
|
||||
btPchar:
|
||||
begin
|
||||
TempStr := #0#0#0#0;
|
||||
if pointer(fvar^.dta^) = nil then
|
||||
Pointer((@TempStr[1])^) := @EmptyPchar
|
||||
else
|
||||
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
|
||||
end;
|
||||
btclass, btinterface, btString:
|
||||
begin
|
||||
TempStr := #0#0#0#0;
|
||||
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
|
||||
end;
|
||||
{$IFNDEF PS_NOWIDESTRING}
|
||||
btWideString: begin
|
||||
TempStr := #0#0#0#0;
|
||||
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
btProcPtr:
|
||||
begin
|
||||
tempstr := #0#0#0#0#0#0#0#0;
|
||||
TMethod((@TempStr[1])^) := MKMethod(Self, Longint(FVar.Dta^));
|
||||
UseReg := false;
|
||||
end;
|
||||
|
||||
{$IFNDEF PS_NOINT64}bts64:
|
||||
begin
|
||||
TempStr:= #0#0#0#0#0#0#0#0;
|
||||
Int64((@TempStr[1])^) := int64(fvar^.dta^);
|
||||
UseReg := False;
|
||||
end;{$ENDIF}
|
||||
end; {case}
|
||||
if UseReg then
|
||||
begin
|
||||
case RegUsage of
|
||||
0: begin EAX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
|
||||
1: begin EDX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
|
||||
2: begin ECX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
|
||||
else begin
|
||||
{$IFDEF FPC}
|
||||
if CallingConv = cdRegister then
|
||||
Stack := Stack + TempStr
|
||||
else
|
||||
{$ENDIF}
|
||||
Stack := TempStr + Stack;
|
||||
end;
|
||||
end;
|
||||
end else begin
|
||||
{$IFDEF FPC}
|
||||
if CallingConv = cdRegister then
|
||||
Stack := Stack + TempStr
|
||||
else
|
||||
{$ENDIF}
|
||||
Stack := TempStr + Stack;
|
||||
end;
|
||||
end;
|
||||
Result := True;
|
||||
end;
|
||||
begin
|
||||
InnerfuseCall := False;
|
||||
if Address = nil then
|
||||
exit; // need address
|
||||
Stack := '';
|
||||
CallData := TPSList.Create;
|
||||
res := rp(res);
|
||||
if res <> nil then
|
||||
res.VarParam := true;
|
||||
try
|
||||
case CallingConv of
|
||||
cdRegister: begin
|
||||
EAX := 0;
|
||||
EDX := 0;
|
||||
ECX := 0;
|
||||
RegUsage := 0;
|
||||
if assigned(_Self) then begin
|
||||
RegUsage := 1;
|
||||
EAX := Longint(_Self);
|
||||
end;
|
||||
for I := 0 to Params.Count - 1 do
|
||||
begin
|
||||
if not GetPtr(rp(Params[I])) then Exit;
|
||||
end;
|
||||
if assigned(res) then begin
|
||||
case res^.aType.BaseType of
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideString, {$ENDIF}
|
||||
btInterface, btArray, btrecord, {$IFNDEF PS_FPCSTRINGWORKAROUND}btstring, {$ENDIF}btVariant, btStaticArray: GetPtr(res);
|
||||
btSet:
|
||||
begin
|
||||
if TPSTypeRec_Set(res.aType).aByteSize >4 then GetPtr(res);
|
||||
end;
|
||||
end;
|
||||
case res^.aType.BaseType of
|
||||
btSet:
|
||||
begin
|
||||
case TPSTypeRec_Set(res.aType).aByteSize of
|
||||
1: byte(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
|
||||
2: word(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
|
||||
3,
|
||||
4: Longint(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
else RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil)
|
||||
end;
|
||||
end;
|
||||
btSingle: tbtsingle(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btDouble: tbtdouble(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btExtended: tbtextended(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btchar,btU8, btS8: tbtu8(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
|
||||
btClass :
|
||||
tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
btu32,bts32: tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
btPChar: pchar(res.dta^) := Pchar(RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
|
||||
{$IFNDEF PS_NOINT64}bts64:
|
||||
begin
|
||||
EAX := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
|
||||
tbts64(res.dta^) := Int64(Cardinal(EDX)) shl 32 or Cardinal(EAX);
|
||||
end;
|
||||
{$ENDIF}
|
||||
btCurrency: tbtCurrency(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4) / 10000;
|
||||
btInterface,
|
||||
btVariant,
|
||||
{$IFNDEF PS_NOWIDESTRING}btWidestring, {$ENDIF}
|
||||
btStaticArray, btArray, btrecord{$IFNDEF PS_FPCSTRINGWORKAROUND}, btstring {$ENDIF}: RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
|
||||
{$IFDEF PS_FPCSTRINGWORKAROUND}
|
||||
btstring: begin
|
||||
eax := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
Longint(res.dta^) := eax;
|
||||
end;
|
||||
{$ENDIF}
|
||||
else
|
||||
exit;
|
||||
end;
|
||||
end else
|
||||
RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
|
||||
Result := True;
|
||||
end;
|
||||
cdPascal: begin
|
||||
RegUsage := 3;
|
||||
for I := 0 to Params.Count - 1 do begin
|
||||
if not GetPtr(Params[i]) then Exit;
|
||||
end;
|
||||
if assigned(res) then begin
|
||||
case res^.aType.BaseType of
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideString, {$ENDIF}btInterface, btArray, btrecord, btstring, btVariant: GetPtr(res);
|
||||
end;
|
||||
end;
|
||||
if assigned(_Self) then begin
|
||||
Stack := #0#0#0#0 +Stack;
|
||||
Pointer((@Stack[1])^) := _Self;
|
||||
end;
|
||||
if assigned(res) then begin
|
||||
case res^.aType.BaseType of
|
||||
btSingle: tbtsingle(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btDouble: tbtdouble(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btExtended: tbtextended(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btChar, btU8, btS8: tbtu8(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
|
||||
btClass, btu32, bts32: tbtu32(res^.Dta^):= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
btPChar: TBTSTRING(res^.dta^) := Pchar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
|
||||
{$IFNDEF PS_NOINT64}bts64:
|
||||
begin
|
||||
EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
|
||||
tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX;
|
||||
end;
|
||||
{$ENDIF}
|
||||
btVariant,
|
||||
btInterface, btrecord, btstring: RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
|
||||
else
|
||||
exit;
|
||||
end;
|
||||
end else
|
||||
RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
|
||||
Result := True;
|
||||
end;
|
||||
cdSafeCall: begin
|
||||
RegUsage := 3;
|
||||
if assigned(res) then begin
|
||||
GetPtr(res);
|
||||
end;
|
||||
for I := Params.Count - 1 downto 0 do begin
|
||||
if not GetPtr(Params[i]) then Exit;
|
||||
end;
|
||||
if assigned(_Self) then begin
|
||||
Stack := #0#0#0#0 +Stack;
|
||||
Pointer((@Stack[1])^) := _Self;
|
||||
end;
|
||||
OleCheck(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
CdCdecl: begin
|
||||
RegUsage := 3;
|
||||
if assigned(_Self) then begin
|
||||
Stack := #0#0#0#0;
|
||||
Pointer((@Stack[1])^) := _Self;
|
||||
end;
|
||||
for I := Params.Count - 1 downto 0 do begin
|
||||
if not GetPtr(Params[I]) then Exit;
|
||||
end;
|
||||
if assigned(res) then begin
|
||||
case res^.aType.BaseType of
|
||||
btSingle: tbtsingle(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btDouble: tbtdouble(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btExtended: tbtextended(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btCHar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
|
||||
btClass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
btPChar: TBTSTRING(res^.dta^) := Pchar(RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
|
||||
{$IFNDEF PS_NOINT64}bts64:
|
||||
begin
|
||||
EAX := RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
|
||||
tbts64(res^.Dta^) := Int64(EAX) shl 32 or EDX;
|
||||
end;
|
||||
{$ENDIF}
|
||||
btVariant, {$IFNDEF PS_NOWIDESTRING}btWideString, {$ENDIF}
|
||||
btInterface,
|
||||
btArray, btrecord, btstring: begin GetPtr(res); RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end;
|
||||
else
|
||||
exit;
|
||||
end;
|
||||
end else begin
|
||||
RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
|
||||
end;
|
||||
Result := True;
|
||||
end;
|
||||
CdStdCall: begin
|
||||
RegUsage := 3;
|
||||
for I := Params.Count - 1 downto 0 do begin
|
||||
if not GetPtr(Params[I]) then exit;
|
||||
end;
|
||||
if assigned(_Self) then begin
|
||||
Stack := #0#0#0#0 + Stack;
|
||||
Pointer((@Stack[1])^) := _Self;
|
||||
end;
|
||||
if assigned(res) then begin
|
||||
case res^.aType.BaseType of
|
||||
btSingle: tbtsingle(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btDouble: tbtdouble(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btExtended: tbtextended(res^.dta^):= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btChar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
|
||||
btclass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
btPChar: TBTSTRING(res^.dta^) := Pchar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
|
||||
{$IFNDEF PS_NOINT64}bts64:
|
||||
begin
|
||||
EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
|
||||
tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX;
|
||||
end;
|
||||
{$ENDIF}
|
||||
btVariant, {$IFNDEF PS_NOWIDESTRING}btWideString, {$ENDIF}
|
||||
btInterface, btArray, btrecord, btstring: begin GetPtr(res); RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end;
|
||||
else
|
||||
exit;
|
||||
end;
|
||||
end else begin
|
||||
RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
|
||||
end;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
for i := CallData.Count -1 downto 0 do
|
||||
begin
|
||||
pp := CallData[i];
|
||||
case pp^ of
|
||||
0: DestroyOpenArray(Self, Pointer(pp));
|
||||
end;
|
||||
end;
|
||||
CallData.Free;
|
||||
end;
|
||||
end;
|
||||
{$ifndef FPC}
|
||||
{$include x86.inc}
|
||||
{$else}
|
||||
{$if defined(cpu86))
|
||||
{$include x86.inc}
|
||||
{$elseif defined(cpupowerpc)}
|
||||
{$include powerpc.inc}
|
||||
{$else}
|
||||
{$fatal Pascal Script is not supported for your architecture at the moment!}
|
||||
{$ifend}
|
||||
{$endif}
|
||||
|
||||
type
|
||||
PScriptMethodInfo = ^TScriptMethodInfo;
|
||||
@ -11329,6 +10636,16 @@ begin
|
||||
s := '';
|
||||
end;
|
||||
|
||||
{$ifdef fpc}
|
||||
{$if defined(cpupowerpc)}
|
||||
{$define ppc}
|
||||
{$ifend}
|
||||
{$endif}
|
||||
{$ifdef ppc}
|
||||
procedure MyAllMethodsHandler;
|
||||
begin
|
||||
end;
|
||||
{$else}
|
||||
|
||||
|
||||
function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer; forward;
|
||||
@ -11642,7 +10959,7 @@ begin
|
||||
raise EPSException.Create(PSErrorToString(Self.SE.ExceptionCode, Self.Se.ExceptionString), Self.Se, Self.Se.ExProc, Self.Se.ExPos);
|
||||
end;
|
||||
end;
|
||||
|
||||
{$endif}
|
||||
function TPSRuntimeClassImporter.FindClass(const Name: string): TPSRuntimeClass;
|
||||
var
|
||||
h, i: Longint;
|
||||
|
||||
706
Source/x86.inc
Normal file
706
Source/x86.inc
Normal file
@ -0,0 +1,706 @@
|
||||
{ implementation of x86 abi }
|
||||
|
||||
function RealFloatCall_Register(p: Pointer;
|
||||
_EAX, _EDX, _ECX: Cardinal;
|
||||
StackData: Pointer;
|
||||
StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
|
||||
): Extended; Stdcall; // make sure all things are on stack
|
||||
var
|
||||
E: Extended;
|
||||
begin
|
||||
asm
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
mov eax, stackdata
|
||||
@@1:
|
||||
mov edx, [eax]
|
||||
push edx
|
||||
sub eax, 4
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@1
|
||||
@@2:
|
||||
mov eax,_EAX
|
||||
mov edx,_EDX
|
||||
mov ecx,_ECX
|
||||
call p
|
||||
fstp tbyte ptr [e]
|
||||
end;
|
||||
Result := E;
|
||||
end;
|
||||
|
||||
function RealFloatCall_Other(p: Pointer;
|
||||
StackData: Pointer;
|
||||
StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
|
||||
): Extended; Stdcall; // make sure all things are on stack
|
||||
var
|
||||
E: Extended;
|
||||
begin
|
||||
asm
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
mov eax, stackdata
|
||||
@@1:
|
||||
mov edx, [eax]
|
||||
push edx
|
||||
sub eax, 4
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@1
|
||||
@@2:
|
||||
call p
|
||||
fstp tbyte ptr [e]
|
||||
end;
|
||||
Result := E;
|
||||
end;
|
||||
|
||||
function RealFloatCall_CDecl(p: Pointer;
|
||||
StackData: Pointer;
|
||||
StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
|
||||
): Extended; Stdcall; // make sure all things are on stack
|
||||
var
|
||||
E: Extended;
|
||||
begin
|
||||
asm
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
mov eax, stackdata
|
||||
@@1:
|
||||
mov edx, [eax]
|
||||
push edx
|
||||
sub eax, 4
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@1
|
||||
@@2:
|
||||
call p
|
||||
fstp tbyte ptr [e]
|
||||
@@5:
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
@@6:
|
||||
pop edx
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@6
|
||||
end;
|
||||
Result := E;
|
||||
end;
|
||||
|
||||
function RealCall_Register(p: Pointer;
|
||||
_EAX, _EDX, _ECX: Cardinal;
|
||||
StackData: Pointer;
|
||||
StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
|
||||
ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
|
||||
var
|
||||
r: Longint;
|
||||
begin
|
||||
asm
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
mov eax, stackdata
|
||||
@@1:
|
||||
mov edx, [eax]
|
||||
push edx
|
||||
sub eax, 4
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@1
|
||||
@@2:
|
||||
mov eax,_EAX
|
||||
mov edx,_EDX
|
||||
mov ecx,_ECX
|
||||
call p
|
||||
mov ecx, resultlength
|
||||
cmp ecx, 0
|
||||
je @@5
|
||||
cmp ecx, 1
|
||||
je @@3
|
||||
cmp ecx, 2
|
||||
je @@4
|
||||
mov r, eax
|
||||
jmp @@5
|
||||
@@3:
|
||||
xor ecx, ecx
|
||||
mov cl, al
|
||||
mov r, ecx
|
||||
jmp @@5
|
||||
@@4:
|
||||
xor ecx, ecx
|
||||
mov cx, ax
|
||||
mov r, ecx
|
||||
@@5:
|
||||
mov ecx, resedx
|
||||
jecxz @@6
|
||||
mov [ecx], edx
|
||||
@@6:
|
||||
end;
|
||||
Result := r;
|
||||
end;
|
||||
|
||||
function RealCall_Other(p: Pointer;
|
||||
StackData: Pointer;
|
||||
StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
|
||||
ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
|
||||
var
|
||||
r: Longint;
|
||||
begin
|
||||
asm
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
mov eax, stackdata
|
||||
@@1:
|
||||
mov edx, [eax]
|
||||
push edx
|
||||
sub eax, 4
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@1
|
||||
@@2:
|
||||
call p
|
||||
mov ecx, resultlength
|
||||
cmp ecx, 0
|
||||
je @@5
|
||||
cmp ecx, 1
|
||||
je @@3
|
||||
cmp ecx, 2
|
||||
je @@4
|
||||
mov r, eax
|
||||
jmp @@5
|
||||
@@3:
|
||||
xor ecx, ecx
|
||||
mov cl, al
|
||||
mov r, ecx
|
||||
jmp @@5
|
||||
@@4:
|
||||
xor ecx, ecx
|
||||
mov cx, ax
|
||||
mov r, ecx
|
||||
@@5:
|
||||
mov ecx, resedx
|
||||
jecxz @@6
|
||||
mov [ecx], edx
|
||||
@@6:
|
||||
end;
|
||||
Result := r;
|
||||
end;
|
||||
|
||||
function RealCall_CDecl(p: Pointer;
|
||||
StackData: Pointer;
|
||||
StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
|
||||
ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
|
||||
var
|
||||
r: Longint;
|
||||
begin
|
||||
asm
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@2
|
||||
mov eax, stackdata
|
||||
@@1:
|
||||
mov edx, [eax]
|
||||
push edx
|
||||
sub eax, 4
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@1
|
||||
@@2:
|
||||
call p
|
||||
mov ecx, resultlength
|
||||
cmp ecx, 0
|
||||
je @@5
|
||||
cmp ecx, 1
|
||||
je @@3
|
||||
cmp ecx, 2
|
||||
je @@4
|
||||
mov r, eax
|
||||
jmp @@5
|
||||
@@3:
|
||||
xor ecx, ecx
|
||||
mov cl, al
|
||||
mov r, ecx
|
||||
jmp @@5
|
||||
@@4:
|
||||
xor ecx, ecx
|
||||
mov cx, ax
|
||||
mov r, ecx
|
||||
@@5:
|
||||
mov ecx, stackdatalen
|
||||
jecxz @@7
|
||||
@@6:
|
||||
pop eax
|
||||
dec ecx
|
||||
or ecx, ecx
|
||||
jnz @@6
|
||||
mov ecx, resedx
|
||||
jecxz @@7
|
||||
mov [ecx], edx
|
||||
@@7:
|
||||
end;
|
||||
Result := r;
|
||||
end;
|
||||
|
||||
const
|
||||
EmptyPchar: array[0..0] of char = #0;
|
||||
|
||||
function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean;
|
||||
var
|
||||
Stack: ansistring;
|
||||
I: Longint;
|
||||
RegUsage: Byte;
|
||||
CallData: TPSList;
|
||||
pp: ^Byte;
|
||||
|
||||
EAX, EDX, ECX: Longint;
|
||||
|
||||
function rp(p: PPSVariantIFC): PPSVariantIFC;
|
||||
begin
|
||||
if p = nil then
|
||||
begin
|
||||
result := nil;
|
||||
exit;
|
||||
end;
|
||||
if p.aType.BaseType = btPointer then
|
||||
begin
|
||||
p^.aType := Pointer(Pointer(IPointer(p^.dta) + 4)^);
|
||||
p^.Dta := Pointer(p^.dta^);
|
||||
end;
|
||||
Result := p;
|
||||
end;
|
||||
|
||||
function GetPtr(fVar: PPSVariantIFC): Boolean;
|
||||
var
|
||||
varPtr: Pointer;
|
||||
UseReg: Boolean;
|
||||
tempstr: string;
|
||||
p: Pointer;
|
||||
begin
|
||||
Result := False;
|
||||
if FVar = nil then exit;
|
||||
if fVar.VarParam then
|
||||
begin
|
||||
case fvar.aType.BaseType of
|
||||
btArray:
|
||||
begin
|
||||
if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then
|
||||
begin
|
||||
p := CreateOpenArray(True, Self, FVar);
|
||||
if p = nil then exit;
|
||||
CallData.Add(p);
|
||||
case RegUsage of
|
||||
0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
|
||||
1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
|
||||
2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
|
||||
else begin
|
||||
Stack := #0#0#0#0 + Stack;
|
||||
Pointer((@Stack[1])^) := POpenArray(p)^.Data;
|
||||
end;
|
||||
end;
|
||||
case RegUsage of
|
||||
0: begin EAX := Longint(POpenArray(p)^.ItemCount - 1); Inc(RegUsage); end;
|
||||
1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
|
||||
2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
|
||||
else begin
|
||||
Stack := #0#0#0#0 + Stack;
|
||||
Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1;
|
||||
end;
|
||||
end;
|
||||
Result := True;
|
||||
Exit;
|
||||
end else begin
|
||||
{$IFDEF PS_DYNARRAY}
|
||||
varptr := fvar.Dta;
|
||||
{$ELSE}
|
||||
Exit;
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
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
|
||||
{$IFNDEF PS_NOINT64}, bts64{$ENDIF}:
|
||||
begin
|
||||
Varptr := fvar.Dta;
|
||||
end;
|
||||
else begin
|
||||
exit; //invalid type
|
||||
end;
|
||||
end; {case}
|
||||
case RegUsage of
|
||||
0: begin EAX := Longint(VarPtr); Inc(RegUsage); end;
|
||||
1: begin EDX := Longint(VarPtr); Inc(RegUsage); end;
|
||||
2: begin ECX := Longint(VarPtr); Inc(RegUsage); end;
|
||||
else begin
|
||||
Stack := #0#0#0#0 + Stack;
|
||||
Pointer((@Stack[1])^) := VarPtr;
|
||||
end;
|
||||
end;
|
||||
end else begin
|
||||
UseReg := True;
|
||||
case fVar^.aType.BaseType of
|
||||
btSet:
|
||||
begin
|
||||
tempstr := #0#0#0#0;
|
||||
case TPSTypeRec_Set(fvar.aType).aByteSize of
|
||||
1: Byte((@tempstr[1])^) := byte(fvar.dta^);
|
||||
2: word((@tempstr[1])^) := word(fvar.dta^);
|
||||
3, 4: cardinal((@tempstr[1])^) := cardinal(fvar.dta^);
|
||||
else
|
||||
pointer((@tempstr[1])^) := fvar.dta;
|
||||
end;
|
||||
end;
|
||||
btArray:
|
||||
begin
|
||||
if Copy(fvar^.aType.ExportName, 1, 10) = '!OPENARRAY' then
|
||||
begin
|
||||
p := CreateOpenArray(False, SElf, FVar);
|
||||
if p =nil then exit;
|
||||
CallData.Add(p);
|
||||
case RegUsage of
|
||||
0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
|
||||
1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
|
||||
2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end;
|
||||
else begin
|
||||
Stack := #0#0#0#0 + Stack;
|
||||
Pointer((@Stack[1])^) := POpenArray(p)^.Data;
|
||||
end;
|
||||
end;
|
||||
case RegUsage of
|
||||
0: begin EAX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
|
||||
1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
|
||||
2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
|
||||
else begin
|
||||
Stack := #0#0#0#0 + Stack;
|
||||
Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1;
|
||||
end;
|
||||
end;
|
||||
Result := True;
|
||||
exit;
|
||||
end else begin
|
||||
{$IFDEF PS_DYNARRAY}
|
||||
TempStr := #0#0#0#0;
|
||||
Pointer((@TempStr[1])^) := Pointer(fvar.Dta^);
|
||||
{$ELSE}
|
||||
Exit;
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
btVariant
|
||||
, btStaticArray, btRecord:
|
||||
begin
|
||||
TempStr := #0#0#0#0;
|
||||
Pointer((@TempStr[1])^) := Pointer(fvar.Dta);
|
||||
end;
|
||||
btDouble: {8 bytes} begin
|
||||
TempStr := #0#0#0#0#0#0#0#0;
|
||||
UseReg := False;
|
||||
double((@TempStr[1])^) := double(fvar.dta^);
|
||||
end;
|
||||
btCurrency: {8 bytes} begin
|
||||
TempStr := #0#0#0#0#0#0#0#0;
|
||||
UseReg := False;
|
||||
currency((@TempStr[1])^) := currency(fvar.dta^);
|
||||
end;
|
||||
btSingle: {4 bytes} begin
|
||||
TempStr := #0#0#0#0;
|
||||
UseReg := False;
|
||||
Single((@TempStr[1])^) := single(fvar.dta^);
|
||||
end;
|
||||
|
||||
btExtended: {10 bytes} begin
|
||||
UseReg := False;
|
||||
TempStr:= #0#0#0#0#0#0#0#0#0#0#0#0;
|
||||
Extended((@TempStr[1])^) := extended(fvar.dta^);
|
||||
end;
|
||||
btChar,
|
||||
btU8,
|
||||
btS8: begin
|
||||
TempStr := char(fVar^.dta^) + #0#0#0;
|
||||
end;
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}
|
||||
btu16, btS16: begin
|
||||
TempStr := #0#0#0#0;
|
||||
Word((@TempStr[1])^) := word(fVar^.dta^);
|
||||
end;
|
||||
btu32, bts32: begin
|
||||
TempStr := #0#0#0#0;
|
||||
Longint((@TempStr[1])^) := Longint(fVar^.dta^);
|
||||
end;
|
||||
btPchar:
|
||||
begin
|
||||
TempStr := #0#0#0#0;
|
||||
if pointer(fvar^.dta^) = nil then
|
||||
Pointer((@TempStr[1])^) := @EmptyPchar
|
||||
else
|
||||
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
|
||||
end;
|
||||
btclass, btinterface, btString:
|
||||
begin
|
||||
TempStr := #0#0#0#0;
|
||||
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
|
||||
end;
|
||||
{$IFNDEF PS_NOWIDESTRING}
|
||||
btWideString: begin
|
||||
TempStr := #0#0#0#0;
|
||||
Pointer((@TempStr[1])^) := pointer(fvar^.dta^);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
btProcPtr:
|
||||
begin
|
||||
tempstr := #0#0#0#0#0#0#0#0;
|
||||
TMethod((@TempStr[1])^) := MKMethod(Self, Longint(FVar.Dta^));
|
||||
UseReg := false;
|
||||
end;
|
||||
|
||||
{$IFNDEF PS_NOINT64}bts64:
|
||||
begin
|
||||
TempStr:= #0#0#0#0#0#0#0#0;
|
||||
Int64((@TempStr[1])^) := int64(fvar^.dta^);
|
||||
UseReg := False;
|
||||
end;{$ENDIF}
|
||||
end; {case}
|
||||
if UseReg then
|
||||
begin
|
||||
case RegUsage of
|
||||
0: begin EAX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
|
||||
1: begin EDX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
|
||||
2: begin ECX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
|
||||
else begin
|
||||
{$IFDEF FPC}
|
||||
if CallingConv = cdRegister then
|
||||
Stack := Stack + TempStr
|
||||
else
|
||||
{$ENDIF}
|
||||
Stack := TempStr + Stack;
|
||||
end;
|
||||
end;
|
||||
end else begin
|
||||
{$IFDEF FPC}
|
||||
if CallingConv = cdRegister then
|
||||
Stack := Stack + TempStr
|
||||
else
|
||||
{$ENDIF}
|
||||
Stack := TempStr + Stack;
|
||||
end;
|
||||
end;
|
||||
Result := True;
|
||||
end;
|
||||
begin
|
||||
InnerfuseCall := False;
|
||||
if Address = nil then
|
||||
exit; // need address
|
||||
Stack := '';
|
||||
CallData := TPSList.Create;
|
||||
res := rp(res);
|
||||
if res <> nil then
|
||||
res.VarParam := true;
|
||||
try
|
||||
case CallingConv of
|
||||
cdRegister: begin
|
||||
EAX := 0;
|
||||
EDX := 0;
|
||||
ECX := 0;
|
||||
RegUsage := 0;
|
||||
if assigned(_Self) then begin
|
||||
RegUsage := 1;
|
||||
EAX := Longint(_Self);
|
||||
end;
|
||||
for I := 0 to Params.Count - 1 do
|
||||
begin
|
||||
if not GetPtr(rp(Params[I])) then Exit;
|
||||
end;
|
||||
if assigned(res) then begin
|
||||
case res^.aType.BaseType of
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideString, {$ENDIF}
|
||||
btInterface, btArray, btrecord, {$IFNDEF PS_FPCSTRINGWORKAROUND}btstring, {$ENDIF}btVariant, btStaticArray: GetPtr(res);
|
||||
btSet:
|
||||
begin
|
||||
if TPSTypeRec_Set(res.aType).aByteSize >4 then GetPtr(res);
|
||||
end;
|
||||
end;
|
||||
case res^.aType.BaseType of
|
||||
btSet:
|
||||
begin
|
||||
case TPSTypeRec_Set(res.aType).aByteSize of
|
||||
1: byte(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
|
||||
2: word(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
|
||||
3,
|
||||
4: Longint(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
else RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil)
|
||||
end;
|
||||
end;
|
||||
btSingle: tbtsingle(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btDouble: tbtdouble(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btExtended: tbtextended(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btchar,btU8, btS8: tbtu8(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
|
||||
btClass :
|
||||
tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
btu32,bts32: tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
btPChar: pchar(res.dta^) := Pchar(RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
|
||||
{$IFNDEF PS_NOINT64}bts64:
|
||||
begin
|
||||
EAX := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
|
||||
tbts64(res.dta^) := Int64(Cardinal(EDX)) shl 32 or Cardinal(EAX);
|
||||
end;
|
||||
{$ENDIF}
|
||||
btCurrency: tbtCurrency(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4) / 10000;
|
||||
btInterface,
|
||||
btVariant,
|
||||
{$IFNDEF PS_NOWIDESTRING}btWidestring, {$ENDIF}
|
||||
btStaticArray, btArray, btrecord{$IFNDEF PS_FPCSTRINGWORKAROUND}, btstring {$ENDIF}: RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
|
||||
{$IFDEF PS_FPCSTRINGWORKAROUND}
|
||||
btstring: begin
|
||||
eax := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
Longint(res.dta^) := eax;
|
||||
end;
|
||||
{$ENDIF}
|
||||
else
|
||||
exit;
|
||||
end;
|
||||
end else
|
||||
RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
|
||||
Result := True;
|
||||
end;
|
||||
cdPascal: begin
|
||||
RegUsage := 3;
|
||||
for I := 0 to Params.Count - 1 do begin
|
||||
if not GetPtr(Params[i]) then Exit;
|
||||
end;
|
||||
if assigned(res) then begin
|
||||
case res^.aType.BaseType of
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideString, {$ENDIF}btInterface, btArray, btrecord, btstring, btVariant: GetPtr(res);
|
||||
end;
|
||||
end;
|
||||
if assigned(_Self) then begin
|
||||
Stack := #0#0#0#0 +Stack;
|
||||
Pointer((@Stack[1])^) := _Self;
|
||||
end;
|
||||
if assigned(res) then begin
|
||||
case res^.aType.BaseType of
|
||||
btSingle: tbtsingle(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btDouble: tbtdouble(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btExtended: tbtextended(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btChar, btU8, btS8: tbtu8(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
|
||||
btClass, btu32, bts32: tbtu32(res^.Dta^):= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
btPChar: TBTSTRING(res^.dta^) := Pchar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
|
||||
{$IFNDEF PS_NOINT64}bts64:
|
||||
begin
|
||||
EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
|
||||
tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX;
|
||||
end;
|
||||
{$ENDIF}
|
||||
btVariant,
|
||||
btInterface, btrecord, btstring: RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
|
||||
else
|
||||
exit;
|
||||
end;
|
||||
end else
|
||||
RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
|
||||
Result := True;
|
||||
end;
|
||||
cdSafeCall: begin
|
||||
RegUsage := 3;
|
||||
if assigned(res) then begin
|
||||
GetPtr(res);
|
||||
end;
|
||||
for I := Params.Count - 1 downto 0 do begin
|
||||
if not GetPtr(Params[i]) then Exit;
|
||||
end;
|
||||
if assigned(_Self) then begin
|
||||
Stack := #0#0#0#0 +Stack;
|
||||
Pointer((@Stack[1])^) := _Self;
|
||||
end;
|
||||
OleCheck(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
CdCdecl: begin
|
||||
RegUsage := 3;
|
||||
if assigned(_Self) then begin
|
||||
Stack := #0#0#0#0;
|
||||
Pointer((@Stack[1])^) := _Self;
|
||||
end;
|
||||
for I := Params.Count - 1 downto 0 do begin
|
||||
if not GetPtr(Params[I]) then Exit;
|
||||
end;
|
||||
if assigned(res) then begin
|
||||
case res^.aType.BaseType of
|
||||
btSingle: tbtsingle(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btDouble: tbtdouble(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btExtended: tbtextended(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btCHar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
|
||||
btClass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
btPChar: TBTSTRING(res^.dta^) := Pchar(RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
|
||||
{$IFNDEF PS_NOINT64}bts64:
|
||||
begin
|
||||
EAX := RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
|
||||
tbts64(res^.Dta^) := Int64(EAX) shl 32 or EDX;
|
||||
end;
|
||||
{$ENDIF}
|
||||
btVariant, {$IFNDEF PS_NOWIDESTRING}btWideString, {$ENDIF}
|
||||
btInterface,
|
||||
btArray, btrecord, btstring: begin GetPtr(res); RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end;
|
||||
else
|
||||
exit;
|
||||
end;
|
||||
end else begin
|
||||
RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
|
||||
end;
|
||||
Result := True;
|
||||
end;
|
||||
CdStdCall: begin
|
||||
RegUsage := 3;
|
||||
for I := Params.Count - 1 downto 0 do begin
|
||||
if not GetPtr(Params[I]) then exit;
|
||||
end;
|
||||
if assigned(_Self) then begin
|
||||
Stack := #0#0#0#0 + Stack;
|
||||
Pointer((@Stack[1])^) := _Self;
|
||||
end;
|
||||
if assigned(res) then begin
|
||||
case res^.aType.BaseType of
|
||||
btSingle: tbtsingle(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btDouble: tbtdouble(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btExtended: tbtextended(res^.dta^):= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
|
||||
btChar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
|
||||
{$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
|
||||
btclass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
|
||||
btPChar: TBTSTRING(res^.dta^) := Pchar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
|
||||
{$IFNDEF PS_NOINT64}bts64:
|
||||
begin
|
||||
EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
|
||||
tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX;
|
||||
end;
|
||||
{$ENDIF}
|
||||
btVariant, {$IFNDEF PS_NOWIDESTRING}btWideString, {$ENDIF}
|
||||
btInterface, btArray, btrecord, btstring: begin GetPtr(res); RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end;
|
||||
else
|
||||
exit;
|
||||
end;
|
||||
end else begin
|
||||
RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
|
||||
end;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
for i := CallData.Count -1 downto 0 do
|
||||
begin
|
||||
pp := CallData[i];
|
||||
case pp^ of
|
||||
0: DestroyOpenArray(Self, Pointer(pp));
|
||||
end;
|
||||
end;
|
||||
CallData.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user