From 04eb8eb42821f1d6547db07f4ee3192289f2243e Mon Sep 17 00:00:00 2001 From: carlokok Date: Tue, 20 Nov 2007 10:43:19 +0000 Subject: [PATCH] git-svn-id: http://code.remobjects.com/svn/pascalscript@41 5c9d2617-0215-0410-a2ee-e80e04d1c6d8 --- Source/changelog.txt | 1 + Source/powerpc.inc | 338 +++++++++++++++++++ Source/uPSCompiler.pas | 28 +- Source/uPSRuntime.pas | 727 ++--------------------------------------- Source/x86.inc | 706 +++++++++++++++++++++++++++++++++++++++ 5 files changed, 1085 insertions(+), 715 deletions(-) create mode 100644 Source/powerpc.inc create mode 100644 Source/x86.inc diff --git a/Source/changelog.txt b/Source/changelog.txt index 124042c..b96c27e 100644 --- a/Source/changelog.txt +++ b/Source/changelog.txt @@ -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 diff --git a/Source/powerpc.inc b/Source/powerpc.inc new file mode 100644 index 0000000..de25edc --- /dev/null +++ b/Source/powerpc.inc @@ -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; diff --git a/Source/uPSCompiler.pas b/Source/uPSCompiler.pas index aad1faa..1ddc97d 100644 --- a/Source/uPSCompiler.pas +++ b/Source/uPSCompiler.pas @@ -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; diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index 704572a..5089ef9 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -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; diff --git a/Source/x86.inc b/Source/x86.inc new file mode 100644 index 0000000..f71e797 --- /dev/null +++ b/Source/x86.inc @@ -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; + +