diff --git a/.gitattributes b/.gitattributes index 5bea747196..582ac4a05f 100644 --- a/.gitattributes +++ b/.gitattributes @@ -7564,6 +7564,7 @@ packages/rtl-objpas/Makefile.fpc svneol=native#text/plain packages/rtl-objpas/Makefile.fpc.fpcmake svneol=native#text/plain packages/rtl-objpas/fpmake.pp svneol=native#text/plain packages/rtl-objpas/src/common/varutils.pp svneol=native#text/plain +packages/rtl-objpas/src/i386/invoke.inc svneol=native#text/pascal packages/rtl-objpas/src/inc/convutil.inc svneol=native#text/plain packages/rtl-objpas/src/inc/convutil.pp svneol=native#text/plain packages/rtl-objpas/src/inc/convutils.pp svneol=native#text/plain @@ -13840,6 +13841,7 @@ tests/test/trtti16.pp svneol=native#text/pascal tests/test/trtti17.pp svneol=native#text/pascal tests/test/trtti18a.pp svneol=native#text/pascal tests/test/trtti18b.pp svneol=native#text/pascal +tests/test/trtti19.pp svneol=native#text/pascal tests/test/trtti2.pp svneol=native#text/plain tests/test/trtti20.pp svneol=native#text/pascal tests/test/trtti3.pp svneol=native#text/plain @@ -14631,6 +14633,7 @@ tests/webtbf/tw26704.pp svneol=native#text/plain tests/webtbf/tw2719.pp svneol=native#text/plain tests/webtbf/tw2721.pp svneol=native#text/plain tests/webtbf/tw2724.pp svneol=native#text/plain +tests/webtbf/tw27378.pp svneol=native#text/pascal tests/webtbf/tw2739.pp svneol=native#text/plain tests/webtbf/tw2751.pp svneol=native#text/plain tests/webtbf/tw2752.pp svneol=native#text/plain @@ -14845,6 +14848,8 @@ tests/webtbf/uw0840b.pp svneol=native#text/plain tests/webtbf/uw0856.pp svneol=native#text/plain tests/webtbf/uw2414.pp svneol=native#text/plain tests/webtbf/uw25283.pp svneol=native#text/plain +tests/webtbf/uw27378a.pp svneol=native#text/pascal +tests/webtbf/uw27378b.pp svneol=native#text/pascal tests/webtbf/uw3450.pp svneol=native#text/plain tests/webtbf/uw3969.pp svneol=native#text/plain tests/webtbf/uw4103.pp svneol=native#text/plain @@ -16169,6 +16174,7 @@ tests/webtbs/tw30179.pp svneol=native#text/pascal tests/webtbs/tw30182.pp svneol=native#text/plain tests/webtbs/tw30202.pp svneol=native#text/pascal tests/webtbs/tw30203.pp svneol=native#text/pascal +tests/webtbs/tw30205.pp svneol=native#text/pascal tests/webtbs/tw30207.pp svneol=native#text/plain tests/webtbs/tw30208.pp svneol=native#text/pascal tests/webtbs/tw3023.pp svneol=native#text/plain diff --git a/compiler/globstat.pas b/compiler/globstat.pas index 124a9f0d8c..5774572b16 100644 --- a/compiler/globstat.pas +++ b/compiler/globstat.pas @@ -60,6 +60,7 @@ type old_settings : tsettings; old_switchesstatestack : tswitchesstatestack; old_switchesstatestackpos : Integer; + old_verbosity : longint; { only saved/restored if "full" is true } old_asmdata : tasmdata; @@ -74,7 +75,7 @@ procedure restore_global_state(const state:tglobalstate;full:boolean); implementation uses - pbase; + pbase,comphook; procedure save_global_state(out state:tglobalstate;full:boolean); begin @@ -106,6 +107,7 @@ uses //flushpendingswitchesstate; oldcurrent_filepos:=current_filepos; old_settings:=current_settings; + old_verbosity:=status.verbosity; if full then begin @@ -142,6 +144,7 @@ uses current_procinfo:=oldcurrent_procinfo; current_filepos:=oldcurrent_filepos; current_settings:=old_settings; + status.verbosity:=old_verbosity; if full then begin diff --git a/compiler/ncgrtti.pas b/compiler/ncgrtti.pas index f5ecdf50a1..dd4b981a6c 100644 --- a/compiler/ncgrtti.pas +++ b/compiler/ncgrtti.pas @@ -241,6 +241,8 @@ implementation if is_open_array(para.vardef) or is_array_of_const(para.vardef) then write_rtti_reference(tcb,tarraydef(para.vardef).elementdef,fullrtti) + else if para.vardef=cformaltype then + write_rtti_reference(tcb,nil,fullrtti) else write_rtti_reference(tcb,para.vardef,fullrtti); write_param_flag(tcb,para); @@ -1361,6 +1363,8 @@ implementation { write param type } if is_open_array(parasym.vardef) or is_array_of_const(parasym.vardef) then write_rtti_reference(tcb,tarraydef(parasym.vardef).elementdef,fullrtti) + else if parasym.vardef=cformaltype then + write_rtti_reference(tcb,nil,fullrtti) else write_rtti_reference(tcb,parasym.vardef,fullrtti); { write name of current parameter } @@ -1408,6 +1412,8 @@ implementation begin if is_open_array(tparavarsym(def.paras[i]).vardef) or is_array_of_const(tparavarsym(def.paras[i]).vardef) then write_rtti_reference(tcb,tarraydef(tparavarsym(def.paras[i]).vardef).elementdef,fullrtti) + else if tparavarsym(def.paras[i]).vardef=cformaltype then + write_rtti_reference(tcb,nil,fullrtti) else write_rtti_reference(tcb,tparavarsym(def.paras[i]).vardef,fullrtti); end; diff --git a/compiler/procdefutil.pas b/compiler/procdefutil.pas index 3fd4029b9c..c508598c6f 100644 --- a/compiler/procdefutil.pas +++ b/compiler/procdefutil.pas @@ -36,7 +36,7 @@ implementation uses cutils, - symbase,symsym,symtable,pparautl; + symbase,symsym,symtable,pparautl,globtype; function create_outline_procdef(const basesymname: string; astruct: tabstractrecorddef; potype: tproctypeoption; resultdef: tdef): tprocdef; @@ -72,6 +72,9 @@ implementation nested procvars modeswitch is active. We must be independent of this switch. } exclude(result.procoptions,po_delphi_nested_cc); result.proctypeoption:=potype; + { always use the default calling convention } + result.proccalloption:=pocall_default; + include(result.procoptions,po_hascallingconvention); handle_calling_convention(result,hcc_default_actions_impl); sym:=cprocsym.create(basesymname+result.unique_id_str); st.insert(sym); diff --git a/packages/rtl-objpas/src/i386/invoke.inc b/packages/rtl-objpas/src/i386/invoke.inc new file mode 100644 index 0000000000..4478600404 --- /dev/null +++ b/packages/rtl-objpas/src/i386/invoke.inc @@ -0,0 +1,455 @@ +{%MainUnit ../inc/rtti.pp} + +{ + This file is part of the Free Pascal run time library. + Copyright (C) 2019 Sven Barth + member of the Free Pascal development team. + + Function call manager for i386 + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +} + +{$define SYSTEM_HAS_INVOKE} + +function ReturnResultInParam(aType: PTypeInfo): Boolean; +var + td: PTypeData; +begin + { Only on Win32 structured types of sizes 1, 2 and 4 are returned directly + instead of a result parameter } + Result := False; + if Assigned(aType) then begin + case aType^.Kind of + tkMethod, + tkSString, + tkAString, + tkUString, + tkWString, + tkInterface, + tkDynArray: + Result := True; + tkArray: begin +{$ifdef win32} + td := GetTypeData(aType); + Result := not (td^.ArrayData.Size in [1, 2, 4]); +{$else} + Result := True; +{$endif} + end; + tkRecord: begin +{$ifdef win32} + td := GetTypeData(aType); + Result := not (td^.RecSize in [1, 2, 4]); +{$else} + Result := True; +{$endif} + end; + tkSet: begin + td := GetTypeData(aType); + case td^.OrdType of + otUByte: + Result := not (td^.SetSize in [1, 2, 4]); + otUWord, + otULong: + Result := False; + end; + end; + end; + end; +end; + +procedure InvokeKernelRegister(aCodeAddress: CodePointer; aArgs: Pointer; aArgCount: LongInt); assembler; nostackframe; +label + nostackargs; +asm + pushl %ebp + movl %esp, %ebp + + pushl %edi + pushl %esi + + pushl %eax + pushl %edx + + cmpl $3, %ecx + jle nostackargs + + { copy arguments to stack } + + subl $3, %ecx + + { allocate count (%ecx) * 4 space on stack } + movl %ecx, %eax + shll $2, %eax + + sub %eax, %esp + + movl %esp, %edi + + lea 12(%edx), %esi + + cld + rep movsd + +nostackargs: + + movl 8(%edx), %ecx + movl (%edx), %eax + movl 4(%edx), %edx + + call -12(%ebp) + + popl %ecx + movl %eax, (%ecx) + movl %edx, 4(%ecx) + + popl %ecx + + popl %esi + popl %edi + + movl %ebp, %esp + popl %ebp +end; + +resourcestring + SErrFailedToConvertArg = 'Failed to convert argument %d of type %s'; + +procedure SystemInvokeRegister(aCodeAddress: CodePointer; const aArgs: TFunctionCallParameterArray; aCallConv: TCallConv; + aResultType: PTypeInfo; aResultValue: Pointer; aFlags: TFunctionCallFlags); +type + PBoolean16 = ^Boolean16; + PBoolean32 = ^Boolean32; + PBoolean64 = ^Boolean64; + PByteBool = ^ByteBool; + PQWordBool = ^QWordBool; +var + regstack: array of PtrUInt; + stackargs: array of SizeInt; + argcount, regidx, stackidx, stackcnt, i: LongInt; + retinparam, isstack: Boolean; + td: PTypeData; + floatres: Extended; + + procedure AddRegArg(aValue: PtrUInt); + begin + if regidx < 3 then begin + regstack[regidx] := aValue; + Inc(regidx); + end else begin + if 3 + stackidx = Length(regstack) then + SetLength(regstack, Length(regstack) * 2); + regstack[3 + stackidx] := aValue; + Inc(stackidx); + end; + end; + + procedure AddStackArg(aValue: PtrUInt); + begin + if 3 + stackidx = Length(regstack) then + SetLength(regstack, Length(regstack) * 2); + regstack[3 + stackidx] := aValue; + Inc(stackidx); + end; + +begin + { for the register calling convention we always have the registers EAX, EDX, ECX + and then the stack; if a parameter does not fit into a register its moved to the + next available stack slot and the next parameter gets a chance to be in a register } + + retinparam := ReturnResultInParam(aResultType); + + { we allocate at least three slots for EAX, ECX and EDX } + argcount := Length(aArgs); + if retinparam then + Inc(argcount); + if argcount < 3 then + SetLength(regstack, 3) + else + SetLength(regstack, argcount); + + regidx := 0; + stackidx := 0; + + SetLength(stackargs, Length(aArgs)); + stackcnt := 0; + + { first pass: handle register parameters } + for i := 0 to High(aArgs) do begin + if regidx >= 3 then begin + { all register locations already used up } + stackargs[stackcnt] := i; + Inc(stackcnt); + Continue; + end; + + isstack := False; + + if pfArray in aArgs[i].Info.ParamFlags then + AddRegArg(PtrUInt(aArgs[i].ValueRef)) + else if aArgs[i].Info.ParamFlags * [pfOut, pfVar, pfConstRef] <> [] then + AddRegArg(PtrUInt(aArgs[i].ValueRef)) + else begin + td := GetTypeData(aArgs[i].Info.ParamType); + case aArgs[i].Info.ParamType^.Kind of + tkSString, + tkMethod: + AddRegArg(PtrUInt(aArgs[i].ValueRef)); + tkArray: + if td^.ArrayData.Size <= 4 then + isstack := True + else + AddRegArg(PtrUInt(aArgs[i].ValueRef)); + tkRecord: + if td^.RecSize <= 4 then + isstack := True + else + AddRegArg(PtrUInt(aArgs[i].ValueRef)); + tkObject, + tkWString, + tkUString, + tkAString, + tkDynArray, + tkClass, + tkClassRef, + tkInterface, + tkInterfaceRaw, + tkProcVar, + tkPointer: + AddRegArg(PPtrUInt(aArgs[i].ValueRef)^); + tkInt64, + tkQWord: + isstack := True; + tkSet: begin + case td^.OrdType of + otUByte: begin + case td^.SetSize of + 0, 1: + AddRegArg(PByte(aArgs[i].ValueRef)^); + 2: + AddRegArg(PWord(aArgs[i].ValueRef)^); + 3: + AddRegArg(PtrUInt(aArgs[i].ValueRef)); + 4: + AddRegArg(PLongWord(aArgs[i].ValueRef)^); + else + AddRegArg(PtrUInt(aArgs[i].ValueRef)); + end; + end; + otUWord: + AddRegArg(PWord(aArgs[i].ValueRef)^); + otULong: + AddRegArg(PLongWord(aArgs[i].ValueRef)^); + end; + end; + tkEnumeration, + tkInteger: begin + case td^.OrdType of + otSByte: AddRegArg(PShortInt(aArgs[i].ValueRef)^); + otUByte: AddRegArg(PByte(aArgs[i].ValueRef)^); + otSWord: AddRegArg(PSmallInt(aArgs[i].ValueRef)^); + otUWord: AddRegArg(PWord(aArgs[i].ValueRef)^); + otSLong: AddRegArg(PLongInt(aArgs[i].ValueRef)^); + otULong: AddRegArg(PLongWord(aArgs[i].ValueRef)^); + end; + end; + tkBool: begin + case td^.OrdType of + otUByte: AddRegArg(ShortInt(System.PBoolean(aArgs[i].ValueRef)^)); + otUWord: AddRegArg(Byte(PBoolean16(aArgs[i].ValueRef)^)); + otULong: AddRegArg(SmallInt(PBoolean32(aArgs[i].ValueRef)^)); + otUQWord: isstack := True; + otSByte: AddRegArg(Word(PByteBool(aArgs[i].ValueRef)^)); + otSWord: AddRegArg(LongInt(PWordBool(aArgs[i].ValueRef)^)); + otSLong: AddRegArg(LongWord(PLongBool(aArgs[i].ValueRef)^)); + otSQWord: isstack := True; + end; + end; + tkFloat: + { all float types are passed in on stack } + isstack := True; + else + raise EInvocationError.CreateFmt(SErrFailedToConvertArg, [i, aArgs[i].Info.ParamType^.Name]); + end; + end; + + if isstack then begin + stackargs[stackcnt] := i; + Inc(stackcnt); + end; + end; + + { then add the result parameter reference (if any) } + if Assigned(aResultType) and retinparam then + AddRegArg(PtrUInt(aResultValue)); + + { second pass: handle stack arguments from right to left } + if stackcnt > 0 then begin + for i := stackcnt - 1 downto 0 do begin + if pfArray in aArgs[stackargs[i]].Info.ParamFlags then + AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef)) + else if aArgs[stackargs[i]].Info.ParamFlags * [pfOut, pfVar, pfConstRef] <> [] then + AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef)) + else begin + td := GetTypeData(aArgs[stackargs[i]].Info.ParamType); + case aArgs[stackargs[i]].Info.ParamType^.Kind of + tkSString, + tkMethod: + AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef)); + tkArray: + if td^.ArrayData.Size <= 4 then + AddStackArg(PPtrUInt(aArgs[stackargs[i]].ValueRef)^) + else + AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef)); + tkRecord: + if td^.RecSize <= 4 then + AddStackArg(PPtrUInt(aArgs[stackargs[i]].ValueRef)^) + else + AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef)); + tkObject, + tkWString, + tkUString, + tkAString, + tkDynArray, + tkClass, + tkClassRef, + tkInterface, + tkInterfaceRaw, + tkProcVar, + tkPointer: + AddStackArg(PPtrUInt(aArgs[stackargs[i]].ValueRef)^); + tkInt64, + tkQWord: begin + AddStackArg(PInt32(PInt64(aArgs[stackargs[i]].ValueRef))[0]); + AddStackArg(PInt32(PInt64(aArgs[stackargs[i]].ValueRef))[1]); + end; + tkSet: begin + case td^.OrdType of + otUByte: begin + case td^.SetSize of + 0, 1: + AddStackArg(PByte(aArgs[stackargs[i]].ValueRef)^); + 2: + AddStackArg(PWord(aArgs[stackargs[i]].ValueRef)^); + 3: + AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef)); + 4: + AddStackArg(PLongWord(aArgs[stackargs[i]].ValueRef)^); + else + AddStackArg(PtrUInt(aArgs[stackargs[i]].ValueRef)); + end; + end; + otUWord: + AddStackArg(PWord(aArgs[stackargs[i]].ValueRef)^); + otULong: + AddStackArg(PLongWord(aArgs[stackargs[i]].ValueRef)^); + end; + end; + tkEnumeration, + tkInteger: begin + case td^.OrdType of + otSByte: AddStackArg(PShortInt(aArgs[stackargs[i]].ValueRef)^); + otUByte: AddStackArg(PByte(aArgs[stackargs[i]].ValueRef)^); + otSWord: AddStackArg(PSmallInt(aArgs[stackargs[i]].ValueRef)^); + otUWord: AddStackArg(PWord(aArgs[stackargs[i]].ValueRef)^); + otSLong: AddStackArg(PLongInt(aArgs[stackargs[i]].ValueRef)^); + otULong: AddStackArg(PLongWord(aArgs[stackargs[i]].ValueRef)^); + end; + end; + tkBool: begin + case td^.OrdType of + otUByte: AddStackArg(ShortInt(System.PBoolean(aArgs[stackargs[i]].ValueRef)^)); + otUWord: AddStackArg(Byte(PBoolean16(aArgs[stackargs[i]].ValueRef)^)); + otULong: AddStackArg(SmallInt(PBoolean32(aArgs[stackargs[i]].ValueRef)^)); + otUQWord: AddStackArg(QWord(PBoolean64(aArgs[stackargs[i]].ValueRef))); + otSByte: AddStackArg(Word(PByteBool(aArgs[stackargs[i]].ValueRef)^)); + otSWord: AddStackArg(LongInt(PWordBool(aArgs[stackargs[i]].ValueRef)^)); + otSLong: AddStackArg(LongWord(PLongBool(aArgs[stackargs[i]].ValueRef)^)); + otSQWord: AddStackArg(PtrUInt(PQWordBool(aArgs[stackargs[i]].ValueRef))); + end; + end; + tkFloat: begin + case td^.FloatType of + ftCurr : begin + AddStackArg(PInt32(PCurrency(aArgs[stackargs[i]].ValueRef))[0]); + AddStackArg(PInt32(PCurrency(aArgs[stackargs[i]].ValueRef))[1]); + end; + ftSingle : AddStackArg(PInt32(PSingle(aArgs[stackargs[i]].ValueRef))^); + ftDouble : begin + AddStackArg(PInt32(PDouble(aArgs[stackargs[i]].ValueRef))[0]); + AddStackArg(PInt32(PDouble(aArgs[stackargs[i]].ValueRef))[1]); + end; + ftExtended: begin + AddStackArg(PInt32(PExtended(aArgs[stackargs[i]].ValueRef))[0]); + AddStackArg(PInt32(PExtended(aArgs[stackargs[i]].ValueRef))[1]); + AddStackArg(PWord(PExtended(aArgs[stackargs[i]].ValueRef))[4]); + end; + ftComp : begin + AddStackArg(PInt32(PComp(aArgs[stackargs[i]].ValueRef))[0]); + AddStackArg(PInt32(PComp(aArgs[stackargs[i]].ValueRef))[1]); + end; + end; + end; + else + raise EInvocationError.CreateFmt(SErrFailedToConvertArg, [stackargs[i], aArgs[stackargs[i]].Info.ParamType^.Name]); + end; + end; + end; + end; + + InvokeKernelRegister(aCodeAddress, @regstack[0], 3 + stackidx); + + if Assigned(aResultType) and not retinparam then begin + if aResultType^.Kind = tkFloat then begin + td := GetTypeData(aResultType); + asm + lea floatres, %eax + fstpt (%eax) + end ['eax']; + case td^.FloatType of + ftSingle: + PSingle(aResultValue)^ := floatres; + ftDouble: + PDouble(aResultValue)^ := floatres; + ftExtended: + PExtended(aResultValue)^ := floatres; + ftCurr: + PCurrency(aResultValue)^ := floatres / 10000; + ftComp: + PComp(aResultValue)^ := floatres; + end; + end else if aResultType^.Kind in [tkQWord, tkInt64] then + PQWord(aResultValue)^ := regstack[0] or (QWord(regstack[1]) shl 32) + else + PPtrUInt(aResultValue)^ := regstack[0]; + end; +end; + +procedure SystemInvoke(aCodeAddress: CodePointer; const aArgs: TFunctionCallParameterArray; aCallConv: TCallConv; + aResultType: PTypeInfo; aResultValue: Pointer; aFlags: TFunctionCallFlags); +begin + case aCallConv of + ccReg: + SystemInvokeRegister(aCodeAddress, aArgs, aCallConv, aResultType, aResultValue, aFlags); + otherwise + Assert(False, 'Unsupported calling convention'); + end; +end; + +const + SystemFunctionCallManager: TFunctionCallManager = ( + Invoke: @SystemInvoke; + CreateCallbackProc: Nil; + CreateCallbackMethod: Nil; + ); + +procedure InitSystemFunctionCallManager; +begin + SetFunctionCallManager([ccReg{, ccCdecl, ccPascal, ccStdCall}], SystemFunctionCallManager); +end; diff --git a/packages/rtl-objpas/src/inc/rtti.pp b/packages/rtl-objpas/src/inc/rtti.pp index 2293cc3898..dc7b656fde 100644 --- a/packages/rtl-objpas/src/inc/rtti.pp +++ b/packages/rtl-objpas/src/inc/rtti.pp @@ -16,6 +16,7 @@ unit Rtti experimental; {$mode objfpc}{$H+} {$modeswitch advancedrecords} +{$goto on} {$Assertions on} { Note: since the Lazarus IDE is not yet capable of correctly handling generic @@ -863,212 +864,6 @@ begin FuncCallMgr[cc] := NoFunctionCallManager; end; -function Invoke(aCodeAddress: CodePointer; const aArgs: TValueArray; - aCallConv: TCallConv; aResultType: PTypeInfo; aIsStatic: Boolean; - aIsConstructor: Boolean): TValue; -var - funcargs: TFunctionCallParameterArray; - i: LongInt; - flags: TFunctionCallFlags; -begin - { sanity check } - if not Assigned(FuncCallMgr[aCallConv].Invoke) then - raise ENotImplemented.Create(SErrInvokeNotImplemented); - - { ToDo: handle IsConstructor } - if aIsConstructor then - raise ENotImplemented.Create(SErrInvokeNotImplemented); - - flags := []; - if aIsStatic then - Include(flags, fcfStatic) - else if Length(aArgs) = 0 then - raise EInvocationError.Create(SErrMissingSelfParam); - - SetLength(funcargs, Length(aArgs)); - for i := Low(aArgs) to High(aArgs) do begin - funcargs[i - Low(aArgs) + Low(funcargs)].ValueRef := aArgs[i].GetReferenceToRawData; - funcargs[i - Low(aArgs) + Low(funcargs)].ValueSize := aArgs[i].DataSize; - funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParamType := aArgs[i].TypeInfo; - funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParamFlags := []; - funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParaLocs := Nil; - end; - - if Assigned(aResultType) then - TValue.Make(Nil, aResultType, Result) - else - Result := TValue.Empty; - - FuncCallMgr[aCallConv].Invoke(aCodeAddress, funcargs, aCallConv, aResultType, Result.GetReferenceToRawData, flags); -end; - -function Invoke(const aName: String; aCodeAddress: CodePointer; aCallConv: TCallConv; aStatic: Boolean; aInstance: TValue; constref aArgs: array of TValue; const aParams: specialize TArray; aReturnType: TRttiType): TValue; -var - arrparam, param: TRttiParameter; - unhidden, highs, i: SizeInt; - args: TFunctionCallParameterArray; - highargs: array of SizeInt; - restype: PTypeInfo; - resptr: Pointer; - mgr: TFunctionCallManager; - flags: TFunctionCallFlags; -begin - mgr := FuncCallMgr[aCallConv]; - if not Assigned(mgr.Invoke) then - raise EInvocationError.CreateFmt(SErrCallConvNotSupported, [CCToStr(aCallConv)]); - - if not Assigned(aCodeAddress) then - raise EInvocationError.CreateFmt(SErrInvokeNoCodeAddr, [aName]); - - unhidden := 0; - highs := 0; - for param in aParams do begin - if unhidden < Length(aArgs) then begin - if pfArray in param.Flags then begin - if Assigned(aArgs[unhidden].TypeInfo) and not aArgs[unhidden].IsArray and (aArgs[unhidden].Kind <> param.ParamType.TypeKind) then - raise EInvocationError.CreateFmt(SErrInvokeArrayArgExpected, [param.Name, aName]); - end else if not (pfHidden in param.Flags) then begin - if aArgs[unhidden].Kind <> param.ParamType.TypeKind then - raise EInvocationError.CreateFmt(SErrInvokeArgInvalidType, [param.Name, aName]); - end; - end; - if not (pfHidden in param.Flags) then - Inc(unhidden); - if pfHigh in param.Flags then - Inc(highs); - end; - - if unhidden <> Length(aArgs) then - raise EInvocationError.CreateFmt(SErrInvokeArgCount, [aName, unhidden, Length(aArgs)]); - - if Assigned(aReturnType) then begin - TValue.Make(Nil, aReturnType.FTypeInfo, Result); - resptr := Result.GetReferenceToRawData; - restype := aReturnType.FTypeInfo; - end else begin - Result := TValue.Empty; - resptr := Nil; - restype := Nil; - end; - - SetLength(highargs, highs); - SetLength(args, Length(aParams)); - unhidden := 0; - highs := 0; - - for i := 0 to High(aParams) do begin - param := aParams[i]; - args[i].Info.ParamType := param.ParamType.FTypeInfo; - args[i].Info.ParamFlags := param.Flags; - args[i].Info.ParaLocs := Nil; - - if pfHidden in param.Flags then begin - if pfSelf in param.Flags then - args[i].ValueRef := aInstance.GetReferenceToRawData - else if pfResult in param.Flags then begin - if not Assigned(restype) then - raise EInvocationError.CreateFmt(SErrInvokeRttiDataError, [aName]); - args[i].ValueRef := resptr; - restype := Nil; - resptr := Nil; - end else if pfHigh in param.Flags then begin - { the corresponding array argument is the *previous* unhidden argument } - if aArgs[unhidden - 1].IsArray then - highargs[highs] := aArgs[unhidden - 1].GetArrayLength - 1 - else if not Assigned(aArgs[unhidden - 1].TypeInfo) then - highargs[highs] := -1 - else - highargs[highs] := 0; - args[i].ValueRef := @highargs[highs]; - Inc(highs); - end; - end else begin - if (pfArray in param.Flags) then begin - if not Assigned(aArgs[unhidden].TypeInfo) then - args[i].ValueRef := Nil - else if aArgs[unhidden].Kind = tkDynArray then - args[i].ValueRef := PPointer(aArgs[unhidden].GetReferenceToRawData)^ - else - args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData; - end else - args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData; - - Inc(unhidden); - end; - end; - - flags := []; - if aStatic then - Include(flags, fcfStatic); - - mgr.Invoke(aCodeAddress, args, aCallConv, restype, resptr, flags); -end; - -function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback; -begin - if not Assigned(FuncCallMgr[aCallConv].CreateCallbackProc) then - raise ENotImplemented.Create(SErrCallbackNotImplented); - - if not Assigned(aHandler) then - raise EArgumentNilException.Create(SErrCallbackHandlerNil); - - Result := FuncCallMgr[aCallConv].CreateCallbackProc(aHandler, aCallConv, aArgs, aResultType, aFlags, aContext); -end; - -function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback; -begin - if not Assigned(FuncCallMgr[aCallConv].CreateCallbackMethod) then - raise ENotImplemented.Create(SErrCallbackNotImplented); - - if not Assigned(aHandler) then - raise EArgumentNilException.Create(SErrCallbackHandlerNil); - - Result := FuncCallMgr[aCallConv].CreateCallbackMethod(aHandler, aCallConv, aArgs, aResultType, aFlags, aContext); -end; - -function IsManaged(TypeInfo: PTypeInfo): boolean; -begin - if Assigned(TypeInfo) then - case TypeInfo^.Kind of - tkAString, - tkLString, - tkWString, - tkUString, - tkInterface, - tkVariant, - tkDynArray : Result := true; - tkArray : Result := IsManaged(GetTypeData(TypeInfo)^.ArrayData.ElType); - tkRecord, - tkObject : - with GetTypeData(TypeInfo)^.RecInitData^ do - Result := (ManagedFieldCount > 0) or Assigned(ManagementOp); - else - Result := false; - end - else - Result := false; -end; - -{$ifndef InLazIDE} -generic function OpenArrayToDynArrayValue(constref aArray: array of T): TValue; -var - arr: specialize TArray; - i: SizeInt; -begin - SetLength(arr, Length(aArray)); - for i := 0 to High(aArray) do - arr[i] := aArray[i]; - Result := TValue.specialize From>(arr); -end; -{$endif} - -{ TRttiPointerType } - -function TRttiPointerType.GetReferredType: TRttiType; -begin - Result := GRttiPool.GetType(FTypeData^.RefType); -end; - { TRttiPool } function TRttiPool.GetTypes: specialize TArray; @@ -1319,6 +1114,1017 @@ begin result := @FBuffer; end; +{ TValue } + +class function TValue.Empty: TValue; +begin + result.FData.FTypeInfo := nil; +{$if SizeOf(TMethod) > SizeOf(QWord)} + Result.FData.FAsMethod.Code := Nil; + Result.FData.FAsMethod.Data := Nil; +{$else} + Result.FData.FAsUInt64 := 0; +{$endif} +end; + +function TValue.GetTypeDataProp: PTypeData; +begin + result := GetTypeData(FData.FTypeInfo); +end; + +function TValue.GetTypeInfo: PTypeInfo; +begin + result := FData.FTypeInfo; +end; + +function TValue.GetTypeKind: TTypeKind; +begin + if not Assigned(FData.FTypeInfo) then + Result := tkUnknown + else + result := FData.FTypeInfo^.Kind; +end; + +function TValue.GetDataSize: SizeInt; +begin + if Assigned(FData.FValueData) and (Kind <> tkSString) then + Result := FData.FValueData.GetDataSize + else begin + Result := 0; + case Kind of + tkEnumeration, + tkBool, + tkInt64, + tkQWord, + tkInteger: + case TypeData^.OrdType of + otSByte, + otUByte: + Result := SizeOf(Byte); + otSWord, + otUWord: + Result := SizeOf(Word); + otSLong, + otULong: + Result := SizeOf(LongWord); + otSQWord, + otUQWord: + Result := SizeOf(QWord); + end; + tkChar: + Result := SizeOf(AnsiChar); + tkFloat: + case TypeData^.FloatType of + ftSingle: + Result := SizeOf(Single); + ftDouble: + Result := SizeOf(Double); + ftExtended: + Result := SizeOf(Extended); + ftComp: + Result := SizeOf(Comp); + ftCurr: + Result := SizeOf(Currency); + end; + tkSet: + Result := TypeData^.SetSize; + tkMethod: + Result := SizeOf(TMethod); + tkSString: + { ShortString can hold max. 254 characters as [0] is Length and [255] is #0 } + Result := SizeOf(ShortString) - 2; + tkVariant: + Result := SizeOf(Variant); + tkProcVar: + Result := SizeOf(CodePointer); + tkWChar: + Result := SizeOf(WideChar); + tkUChar: + Result := SizeOf(UnicodeChar); + tkFile: + { ToDo } + Result := SizeOf(TTextRec); + tkAString, + tkWString, + tkUString, + tkInterface, + tkDynArray, + tkClass, + tkHelper, + tkClassRef, + tkInterfaceRaw, + tkPointer: + Result := SizeOf(Pointer); + tkObject, + tkRecord: + Result := TypeData^.RecSize; + tkArray: + Result := TypeData^.ArrayData.Size; + tkUnknown, + tkLString: + Assert(False); + end; + end; +end; + +class procedure TValue.Make(ABuffer: pointer; ATypeInfo: PTypeInfo; out result: TValue); +type + PBoolean16 = ^Boolean16; + PBoolean32 = ^Boolean32; + PBoolean64 = ^Boolean64; + PByteBool = ^ByteBool; + PQWordBool = ^QWordBool; + PMethod = ^TMethod; +var + td: PTypeData; + size: SizeInt; +begin + result.FData.FTypeInfo:=ATypeInfo; + { resets the whole variant part; FValueData is already Nil } +{$if SizeOf(TMethod) > SizeOf(QWord)} + Result.FData.FAsMethod.Code := Nil; + Result.FData.FAsMethod.Data := Nil; +{$else} + Result.FData.FAsUInt64 := 0; +{$endif} + if not Assigned(ATypeInfo) then + Exit; + { first handle those types that need a TValueData implementation } + case ATypeInfo^.Kind of + tkSString : begin + td := GetTypeData(ATypeInfo); + result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, td^.MaxLength + 1, ATypeInfo, True); + end; + tkWString, + tkUString, + tkAString : result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True); + tkDynArray : result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True); + tkArray : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, Result.TypeData^.ArrayData.Size, ATypeInfo, False); + tkObject, + tkRecord : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, Result.TypeData^.RecSize, ATypeInfo, False); + tkInterface: result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True); + end; + if not Assigned(ABuffer) then + Exit; + { now handle those that are happy with the variant part of FData } + case ATypeInfo^.Kind of + tkSString, + tkWString, + tkUString, + tkAString, + tkDynArray, + tkArray, + tkObject, + tkRecord, + tkInterface: + { ignore } + ; + tkClass : result.FData.FAsObject := PPointer(ABuffer)^; + tkClassRef : result.FData.FAsClass := PClass(ABuffer)^; + tkInterfaceRaw : result.FData.FAsPointer := PPointer(ABuffer)^; + tkInt64 : result.FData.FAsSInt64 := PInt64(ABuffer)^; + tkQWord : result.FData.FAsUInt64 := PQWord(ABuffer)^; + tkProcVar : result.FData.FAsMethod.Code := PCodePointer(ABuffer)^; + tkMethod : result.FData.FAsMethod := PMethod(ABuffer)^; + tkPointer : result.FData.FAsPointer := PPointer(ABuffer)^; + tkSet : begin + td := GetTypeData(ATypeInfo); + case td^.OrdType of + otUByte: begin + { this can either really be 1 Byte or a set > 32-bit, so + check the underlying type } + if not (td^.CompType^.Kind in [tkInteger,tkEnumeration]) then + raise Exception.CreateFmt(SErrUnableToGetValueForType,[ATypeInfo^.Name]); + case td^.SetSize of + 0, 1: + Result.FData.FAsUByte := PByte(ABuffer)^; + { these two cases shouldn't happen, but better safe than sorry... } + 2: + Result.FData.FAsUWord := PWord(ABuffer)^; + 3, 4: + Result.FData.FAsULong := PLongWord(ABuffer)^; + { maybe we should also allow storage as otUQWord? } + 5..8: + Result.FData.FAsUInt64 := PQWord(ABuffer)^; + else + Result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, td^.SetSize, ATypeInfo, False); + end; + end; + otUWord: + Result.FData.FAsUWord := PWord(ABuffer)^; + otULong: + Result.FData.FAsULong := PLongWord(ABuffer)^; + else + { ehm... Panic? } + raise Exception.CreateFmt(SErrUnableToGetValueForType,[ATypeInfo^.Name]); + end; + end; + tkEnumeration, + tkInteger : begin + case GetTypeData(ATypeInfo)^.OrdType of + otSByte: result.FData.FAsSByte := PShortInt(ABuffer)^; + otUByte: result.FData.FAsUByte := PByte(ABuffer)^; + otSWord: result.FData.FAsSWord := PSmallInt(ABuffer)^; + otUWord: result.FData.FAsUWord := PWord(ABuffer)^; + otSLong: result.FData.FAsSLong := PLongInt(ABuffer)^; + otULong: result.FData.FAsULong := PLongWord(ABuffer)^; + end; + end; + tkBool : begin + case GetTypeData(ATypeInfo)^.OrdType of + otUByte: result.FData.FAsUByte := Byte(System.PBoolean(ABuffer)^); + otUWord: result.FData.FAsUWord := Word(PBoolean16(ABuffer)^); + otULong: result.FData.FAsULong := DWord(PBoolean32(ABuffer)^); + otUQWord: result.FData.FAsUInt64 := QWord(PBoolean64(ABuffer)^); + otSByte: result.FData.FAsSByte := ShortInt(PByteBool(ABuffer)^); + otSWord: result.FData.FAsSWord := SmallInt(PWordBool(ABuffer)^); + otSLong: result.FData.FAsSLong := LongInt(PLongBool(ABuffer)^); + otSQWord: result.FData.FAsSInt64 := Int64(PQWordBool(ABuffer)^); + end; + end; + tkFloat : begin + case GetTypeData(ATypeInfo)^.FloatType of + ftCurr : result.FData.FAsCurr := PCurrency(ABuffer)^; + ftSingle : result.FData.FAsSingle := PSingle(ABuffer)^; + ftDouble : result.FData.FAsDouble := PDouble(ABuffer)^; + ftExtended: result.FData.FAsExtended := PExtended(ABuffer)^; + ftComp : result.FData.FAsComp := PComp(ABuffer)^; + end; + end; + else + raise Exception.CreateFmt(SErrUnableToGetValueForType,[ATypeInfo^.Name]); + end; +end; + +class procedure TValue.MakeOpenArray(AArray: Pointer; ALength: SizeInt; ATypeInfo: PTypeInfo; out Result: TValue); +var + el: TValue; +begin + Result.FData.FTypeInfo := ATypeInfo; + { resets the whole variant part; FValueData is already Nil } +{$if SizeOf(TMethod) > SizeOf(QWord)} + Result.FData.FAsMethod.Code := Nil; + Result.FData.FAsMethod.Data := Nil; +{$else} + Result.FData.FAsUInt64 := 0; +{$endif} + if not Assigned(ATypeInfo) then + Exit; + if ATypeInfo^.Kind <> tkArray then + Exit; + if not Assigned(AArray) then + Exit; + if ALength < 0 then + Exit; + Result.FData.FValueData := TValueDataIntImpl.CreateRef(@AArray, ATypeInfo, False); + Result.FData.FArrLength := ALength; + Make(Nil, Result.TypeData^.ArrayData.ElType, el); + Result.FData.FElSize := el.DataSize; +end; + +{$ifndef NoGenericMethods} +generic class function TValue.From(constref aValue: T): TValue; +begin + TValue.Make(@aValue, System.TypeInfo(T), Result); +end; + +generic class function TValue.FromOpenArray(constref aValue: array of T): TValue; +var + arrdata: Pointer; +begin + if Length(aValue) > 0 then + arrdata := @aValue[0] + else + arrdata := Nil; + TValue.MakeOpenArray(arrdata, Length(aValue), System.TypeInfo(aValue), Result); +end; +{$endif} + +function TValue.GetIsEmpty: boolean; +begin + result := (FData.FTypeInfo=nil) or + ((Kind in [tkSString, tkObject, tkRecord, tkArray]) and not Assigned(FData.FValueData)) or + ((Kind in [tkClass, tkClassRef, tkInterfaceRaw]) and not Assigned(FData.FAsPointer)); +end; + +function TValue.IsArray: boolean; +begin + result := kind in [tkArray, tkDynArray]; +end; + +function TValue.IsOpenArray: Boolean; +var + td: PTypeData; +begin + td := TypeData; + Result := (Kind = tkArray) and (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) +end; + +function TValue.AsString: string; +begin + if System.GetTypeKind(String) = tkUString then + Result := String(AsUnicodeString) + else + Result := String(AsAnsiString); +end; + +function TValue.AsUnicodeString: UnicodeString; +begin + if (Kind in [tkSString, tkAString, tkUString, tkWString]) and not Assigned(FData.FValueData) then + Result := '' + else + case Kind of + tkSString: + Result := UnicodeString(PShortString(FData.FValueData.GetReferenceToRawData)^); + tkAString: + Result := UnicodeString(PAnsiString(FData.FValueData.GetReferenceToRawData)^); + tkWString: + Result := UnicodeString(PWideString(FData.FValueData.GetReferenceToRawData)^); + tkUString: + Result := UnicodeString(PUnicodeString(FData.FValueData.GetReferenceToRawData)^); + else + raise EInvalidCast.Create(SErrInvalidTypecast); + end; +end; + +function TValue.AsAnsiString: AnsiString; +begin + if (Kind in [tkSString, tkAString, tkUString, tkWString]) and not Assigned(FData.FValueData) then + Result := '' + else + case Kind of + tkSString: + Result := AnsiString(PShortString(FData.FValueData.GetReferenceToRawData)^); + tkAString: + Result := AnsiString(PAnsiString(FData.FValueData.GetReferenceToRawData)^); + tkWString: + Result := AnsiString(PWideString(FData.FValueData.GetReferenceToRawData)^); + tkUString: + Result := AnsiString(PUnicodeString(FData.FValueData.GetReferenceToRawData)^); + else + raise EInvalidCast.Create(SErrInvalidTypecast); + end; +end; + +function TValue.AsExtended: Extended; +begin + if Kind = tkFloat then + begin + case TypeData^.FloatType of + ftSingle : result := FData.FAsSingle; + ftDouble : result := FData.FAsDouble; + ftExtended : result := FData.FAsExtended; + ftCurr : result := FData.FAsCurr; + ftComp : result := FData.FAsComp; + else + raise EInvalidCast.Create(SErrInvalidTypecast); + end; + end + else + raise EInvalidCast.Create(SErrInvalidTypecast); +end; + +function TValue.IsObject: boolean; +begin + result := (Kind = tkClass) or ((Kind = tkUnknown) and not Assigned(FData.FAsObject)); +end; + +function TValue.IsClass: boolean; +begin + result := (Kind = tkClassRef) or ((Kind in [tkClass,tkUnknown]) and not Assigned(FData.FAsObject)); +end; + +function TValue.IsOrdinal: boolean; +begin + result := (Kind in [tkInteger, tkInt64, tkQWord, tkBool]) or + ((Kind in [tkClass, tkClassRef, tkInterfaceRaw, tkUnknown]) and not Assigned(FData.FAsPointer)); +end; + +function TValue.IsType(ATypeInfo: PTypeInfo): boolean; +begin + result := ATypeInfo = TypeInfo; +end; + +function TValue.AsObject: TObject; +begin + if IsObject or (IsClass and not Assigned(FData.FAsObject)) then + result := TObject(FData.FAsObject) + else + raise EInvalidCast.Create(SErrInvalidTypecast); +end; + +function TValue.AsClass: TClass; +begin + if IsClass then + result := FData.FAsClass + else + raise EInvalidCast.Create(SErrInvalidTypecast); +end; + +function TValue.AsBoolean: boolean; +begin + if (Kind = tkBool) then + case TypeData^.OrdType of + otSByte: Result := ByteBool(FData.FAsSByte); + otUByte: Result := Boolean(FData.FAsUByte); + otSWord: Result := WordBool(FData.FAsSWord); + otUWord: Result := Boolean16(FData.FAsUWord); + otSLong: Result := LongBool(FData.FAsSLong); + otULong: Result := Boolean32(FData.FAsULong); + otSQWord: Result := QWordBool(FData.FAsSInt64); + otUQWord: Result := Boolean64(FData.FAsUInt64); + end + else + raise EInvalidCast.Create(SErrInvalidTypecast); +end; + +function TValue.AsOrdinal: Int64; +begin + if IsOrdinal then + if Kind in [tkClass, tkClassRef, tkInterfaceRaw, tkUnknown] then + Result := 0 + else + case TypeData^.OrdType of + otSByte: Result := FData.FAsSByte; + otUByte: Result := FData.FAsUByte; + otSWord: Result := FData.FAsSWord; + otUWord: Result := FData.FAsUWord; + otSLong: Result := FData.FAsSLong; + otULong: Result := FData.FAsULong; + otSQWord: Result := FData.FAsSInt64; + otUQWord: Result := FData.FAsUInt64; + end + else + raise EInvalidCast.Create(SErrInvalidTypecast); +end; + +function TValue.AsCurrency: Currency; +begin + if (Kind = tkFloat) and (TypeData^.FloatType=ftCurr) then + result := FData.FAsCurr + else + raise EInvalidCast.Create(SErrInvalidTypecast); +end; + +function TValue.AsInteger: Integer; +begin + if Kind in [tkInteger, tkInt64, tkQWord] then + case TypeData^.OrdType of + otSByte: Result := FData.FAsSByte; + otUByte: Result := FData.FAsUByte; + otSWord: Result := FData.FAsSWord; + otUWord: Result := FData.FAsUWord; + otSLong: Result := FData.FAsSLong; + otULong: Result := FData.FAsULong; + otSQWord: Result := FData.FAsSInt64; + otUQWord: Result := FData.FAsUInt64; + end + else + raise EInvalidCast.Create(SErrInvalidTypecast); +end; + +function TValue.AsInt64: Int64; +begin + if Kind in [tkInteger, tkInt64, tkQWord] then + case TypeData^.OrdType of + otSByte: Result := FData.FAsSByte; + otUByte: Result := FData.FAsUByte; + otSWord: Result := FData.FAsSWord; + otUWord: Result := FData.FAsUWord; + otSLong: Result := FData.FAsSLong; + otULong: Result := FData.FAsULong; + otSQWord: Result := FData.FAsSInt64; + otUQWord: Result := FData.FAsUInt64; + end + else if (Kind = tkFloat) and (TypeData^.FloatType = ftComp) then + Result := Int64(FData.FAsComp) + else + raise EInvalidCast.Create(SErrInvalidTypecast); +end; + +function TValue.AsUInt64: QWord; +begin + if Kind in [tkInteger, tkInt64, tkQWord] then + case TypeData^.OrdType of + otSByte: Result := FData.FAsSByte; + otUByte: Result := FData.FAsUByte; + otSWord: Result := FData.FAsSWord; + otUWord: Result := FData.FAsUWord; + otSLong: Result := FData.FAsSLong; + otULong: Result := FData.FAsULong; + otSQWord: Result := FData.FAsSInt64; + otUQWord: Result := FData.FAsUInt64; + end + else if (Kind = tkFloat) and (TypeData^.FloatType = ftComp) then + Result := QWord(FData.FAsComp) + else + raise EInvalidCast.Create(SErrInvalidTypecast); +end; + +function TValue.AsInterface: IInterface; +begin + if Kind = tkInterface then + Result := PInterface(FData.FValueData.GetReferenceToRawData)^ + else if (Kind in [tkClass, tkClassRef, tkUnknown]) and not Assigned(FData.FAsPointer) then + Result := Nil + else + raise EInvalidCast.Create(SErrInvalidTypecast); +end; + +function TValue.ToString: String; +begin + case Kind of + tkWString, + tkUString : result := AsUnicodeString; + tkSString, + tkAString : result := AsAnsiString; + tkInteger : result := IntToStr(AsInteger); + tkQWord : result := IntToStr(AsUInt64); + tkInt64 : result := IntToStr(AsInt64); + tkBool : result := BoolToStr(AsBoolean, True); + else + result := ''; + end; +end; + +function TValue.GetArrayLength: SizeInt; +var + td: PTypeData; +begin + if not IsArray then + raise EInvalidCast.Create(SErrInvalidTypecast); + if Kind = tkDynArray then + Result := DynArraySize(PPointer(FData.FValueData.GetReferenceToRawData)^) + else begin + td := TypeData; + if (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) then + Result := FData.FArrLength + else + Result := td^.ArrayData.ElCount; + end; +end; + +function TValue.GetArrayElement(AIndex: SizeInt): TValue; +var + data: Pointer; + eltype: PTypeInfo; + elsize: SizeInt; + td: PTypeData; +begin + if not IsArray then + raise EInvalidCast.Create(SErrInvalidTypecast); + if Kind = tkDynArray then begin + data := DynArrayIndex(PPointer(FData.FValueData.GetReferenceToRawData)^, [AIndex], FData.FTypeInfo); + eltype := TypeData^.elType2; + end else begin + td := TypeData; + eltype := td^.ArrayData.ElType; + { open array? } + if (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) then begin + data := PPointer(FData.FValueData.GetReferenceToRawData)^; + elsize := FData.FElSize + end else begin + data := FData.FValueData.GetReferenceToRawData; + elsize := td^.ArrayData.Size div td^.ArrayData.ElCount; + end; + data := PByte(data) + AIndex * elsize; + end; + { MakeWithoutCopy? } + Make(data, eltype, Result); +end; + +procedure TValue.SetArrayElement(AIndex: SizeInt; constref AValue: TValue); +var + data: Pointer; + eltype: PTypeInfo; + elsize: SizeInt; + td, tdv: PTypeData; +begin + if not IsArray then + raise EInvalidCast.Create(SErrInvalidTypecast); + if Kind = tkDynArray then begin + data := DynArrayIndex(PPointer(FData.FValueData.GetReferenceToRawData)^, [AIndex], FData.FTypeInfo); + eltype := TypeData^.elType2; + end else begin + td := TypeData; + eltype := td^.ArrayData.ElType; + { open array? } + if (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) then begin + data := PPointer(FData.FValueData.GetReferenceToRawData)^; + elsize := FData.FElSize + end else begin + data := FData.FValueData.GetReferenceToRawData; + elsize := td^.ArrayData.Size div td^.ArrayData.ElCount; + end; + data := PByte(data) + AIndex * elsize; + end; + { maybe we'll later on allow some typecasts, but for now be restrictive } + if eltype^.Kind <> AValue.Kind then + raise EInvalidCast.Create(SErrInvalidTypecast); + td := GetTypeData(eltype); + tdv := AValue.TypeData; + if ((eltype^.Kind in [tkInteger, tkBool, tkEnumeration, tkSet]) and (td^.OrdType <> tdv^.OrdType)) or + ((eltype^.Kind = tkFloat) and (td^.FloatType <> tdv^.FloatType)) then + raise EInvalidCast.Create(SErrInvalidTypecast); + if Assigned(AValue.FData.FValueData) and (eltype^.Kind <> tkSString) then + IntCopy(AValue.FData.FValueData.GetReferenceToRawData, data, eltype) + else + Move(AValue.GetReferenceToRawData^, data^, AValue.DataSize); +end; + +function TValue.TryAsOrdinal(out AResult: int64): boolean; +begin + result := IsOrdinal; + if result then + AResult := AsOrdinal; +end; + +function TValue.GetReferenceToRawData: Pointer; +begin + if not Assigned(FData.FTypeInfo) then + Result := Nil + else if Assigned(FData.FValueData) then + Result := FData.FValueData.GetReferenceToRawData + else begin + Result := Nil; + case Kind of + tkInteger, + tkEnumeration, + tkInt64, + tkQWord, + tkBool: + case TypeData^.OrdType of + otSByte: + Result := @FData.FAsSByte; + otUByte: + Result := @FData.FAsUByte; + otSWord: + Result := @FData.FAsSWord; + otUWord: + Result := @FData.FAsUWord; + otSLong: + Result := @FData.FAsSLong; + otULong: + Result := @FData.FAsULong; + otSQWord: + Result := @FData.FAsSInt64; + otUQWord: + Result := @FData.FAsUInt64; + end; + tkSet: begin + case TypeData^.OrdType of + otUByte: begin + case TypeData^.SetSize of + 1: + Result := @FData.FAsUByte; + 2: + Result := @FData.FAsUWord; + 3, 4: + Result := @FData.FAsULong; + 5..8: + Result := @FData.FAsUInt64; + else + { this should have gone through FAsValueData :/ } + Result := Nil; + end; + end; + otUWord: + Result := @FData.FAsUWord; + otULong: + Result := @FData.FAsULong; + else + Result := Nil; + end; + end; + tkChar: + Result := @FData.FAsUByte; + tkFloat: + case TypeData^.FloatType of + ftSingle: + Result := @FData.FAsSingle; + ftDouble: + Result := @FData.FAsDouble; + ftExtended: + Result := @FData.FAsExtended; + ftComp: + Result := @FData.FAsComp; + ftCurr: + Result := @FData.FAsCurr; + end; + tkMethod: + Result := @FData.FAsMethod; + tkClass: + Result := @FData.FAsObject; + tkWChar: + Result := @FData.FAsUWord; + tkInterfaceRaw: + Result := @FData.FAsPointer; + tkProcVar: + Result := @FData.FAsMethod.Code; + tkUChar: + Result := @FData.FAsUWord; + tkFile: + Result := @FData.FAsPointer; + tkClassRef: + Result := @FData.FAsClass; + tkPointer: + Result := @FData.FAsPointer; + tkVariant, + tkDynArray, + tkArray, + tkObject, + tkRecord, + tkInterface, + tkSString, + tkLString, + tkAString, + tkUString, + tkWString: + Assert(false, 'Managed/complex type not handled through IValueData'); + end; + end; +end; + +procedure TValue.ExtractRawData(ABuffer: Pointer); +begin + if Assigned(FData.FValueData) then + FData.FValueData.ExtractRawData(ABuffer) + else if Assigned(FData.FTypeInfo) then + Move((@FData.FAsPointer)^, ABuffer^, DataSize); +end; + +procedure TValue.ExtractRawDataNoCopy(ABuffer: Pointer); +begin + if Assigned(FData.FValueData) then + FData.FValueData.ExtractRawDataNoCopy(ABuffer) + else if Assigned(FData.FTypeInfo) then + Move((@FData.FAsPointer)^, ABuffer^, DataSize); +end; + +class operator TValue.:=(const AValue: String): TValue; +begin + Make(@AValue, System.TypeInfo(AValue), Result); +end; + +class operator TValue.:=(AValue: LongInt): TValue; +begin + Make(@AValue, System.TypeInfo(AValue), Result); +end; + +class operator TValue.:=(AValue: Single): TValue; +begin + Make(@AValue, System.TypeInfo(AValue), Result); +end; + +class operator TValue.:=(AValue: Double): TValue; +begin + Make(@AValue, System.TypeInfo(AValue), Result); +end; + +{$ifdef FPC_HAS_TYPE_EXTENDED} +class operator TValue.:=(AValue: Extended): TValue; +begin + Make(@AValue, System.TypeInfo(AValue), Result); +end; +{$endif} + +class operator TValue.:=(AValue: Currency): TValue; +begin + Make(@AValue, System.TypeInfo(AValue), Result); +end; + +class operator TValue.:=(AValue: Int64): TValue; +begin + Make(@AValue, System.TypeInfo(AValue), Result); +end; + +class operator TValue.:=(AValue: QWord): TValue; +begin + Make(@AValue, System.TypeInfo(AValue), Result); +end; + +class operator TValue.:=(AValue: TObject): TValue; +begin + Make(@AValue, System.TypeInfo(AValue), Result); +end; + +class operator TValue.:=(AValue: TClass): TValue; +begin + Make(@AValue, System.TypeInfo(AValue), Result); +end; + +class operator TValue.:=(AValue: Boolean): TValue; +begin + Make(@AValue, System.TypeInfo(AValue), Result); +end; + + +function Invoke(aCodeAddress: CodePointer; const aArgs: TValueArray; + aCallConv: TCallConv; aResultType: PTypeInfo; aIsStatic: Boolean; + aIsConstructor: Boolean): TValue; +var + funcargs: TFunctionCallParameterArray; + i: LongInt; + flags: TFunctionCallFlags; +begin + { sanity check } + if not Assigned(FuncCallMgr[aCallConv].Invoke) then + raise ENotImplemented.Create(SErrInvokeNotImplemented); + + { ToDo: handle IsConstructor } + if aIsConstructor then + raise ENotImplemented.Create(SErrInvokeNotImplemented); + + flags := []; + if aIsStatic then + Include(flags, fcfStatic) + else if Length(aArgs) = 0 then + raise EInvocationError.Create(SErrMissingSelfParam); + + SetLength(funcargs, Length(aArgs)); + for i := Low(aArgs) to High(aArgs) do begin + funcargs[i - Low(aArgs) + Low(funcargs)].ValueRef := aArgs[i].GetReferenceToRawData; + funcargs[i - Low(aArgs) + Low(funcargs)].ValueSize := aArgs[i].DataSize; + funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParamType := aArgs[i].TypeInfo; + funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParamFlags := []; + funcargs[i - Low(aArgs) + Low(funcargs)].Info.ParaLocs := Nil; + end; + + if Assigned(aResultType) then + TValue.Make(Nil, aResultType, Result) + else + Result := TValue.Empty; + + FuncCallMgr[aCallConv].Invoke(aCodeAddress, funcargs, aCallConv, aResultType, Result.GetReferenceToRawData, flags); +end; + +function Invoke(const aName: String; aCodeAddress: CodePointer; aCallConv: TCallConv; aStatic: Boolean; aInstance: TValue; constref aArgs: array of TValue; const aParams: specialize TArray; aReturnType: TRttiType): TValue; +var + arrparam, param: TRttiParameter; + unhidden, highs, i: SizeInt; + args: TFunctionCallParameterArray; + highargs: array of SizeInt; + restype: PTypeInfo; + resptr: Pointer; + mgr: TFunctionCallManager; + flags: TFunctionCallFlags; +begin + mgr := FuncCallMgr[aCallConv]; + if not Assigned(mgr.Invoke) then + raise EInvocationError.CreateFmt(SErrCallConvNotSupported, [CCToStr(aCallConv)]); + + if not Assigned(aCodeAddress) then + raise EInvocationError.CreateFmt(SErrInvokeNoCodeAddr, [aName]); + + unhidden := 0; + highs := 0; + for param in aParams do begin + if unhidden < Length(aArgs) then begin + if pfArray in param.Flags then begin + if Assigned(aArgs[unhidden].TypeInfo) and not aArgs[unhidden].IsArray and (aArgs[unhidden].Kind <> param.ParamType.TypeKind) then + raise EInvocationError.CreateFmt(SErrInvokeArrayArgExpected, [param.Name, aName]); + end else if not (pfHidden in param.Flags) then begin + if aArgs[unhidden].Kind <> param.ParamType.TypeKind then + raise EInvocationError.CreateFmt(SErrInvokeArgInvalidType, [param.Name, aName]); + end; + end; + if not (pfHidden in param.Flags) then + Inc(unhidden); + if pfHigh in param.Flags then + Inc(highs); + end; + + if unhidden <> Length(aArgs) then + raise EInvocationError.CreateFmt(SErrInvokeArgCount, [aName, unhidden, Length(aArgs)]); + + if Assigned(aReturnType) then begin + TValue.Make(Nil, aReturnType.FTypeInfo, Result); + resptr := Result.GetReferenceToRawData; + restype := aReturnType.FTypeInfo; + end else begin + Result := TValue.Empty; + resptr := Nil; + restype := Nil; + end; + + SetLength(highargs, highs); + SetLength(args, Length(aParams)); + unhidden := 0; + highs := 0; + + for i := 0 to High(aParams) do begin + param := aParams[i]; + args[i].Info.ParamType := param.ParamType.FTypeInfo; + args[i].Info.ParamFlags := param.Flags; + args[i].Info.ParaLocs := Nil; + + if pfHidden in param.Flags then begin + if pfSelf in param.Flags then + args[i].ValueRef := aInstance.GetReferenceToRawData + else if pfResult in param.Flags then begin + if not Assigned(restype) then + raise EInvocationError.CreateFmt(SErrInvokeRttiDataError, [aName]); + args[i].ValueRef := resptr; + restype := Nil; + resptr := Nil; + end else if pfHigh in param.Flags then begin + { the corresponding array argument is the *previous* unhidden argument } + if aArgs[unhidden - 1].IsArray then + highargs[highs] := aArgs[unhidden - 1].GetArrayLength - 1 + else if not Assigned(aArgs[unhidden - 1].TypeInfo) then + highargs[highs] := -1 + else + highargs[highs] := 0; + args[i].ValueRef := @highargs[highs]; + Inc(highs); + end; + end else begin + if (pfArray in param.Flags) then begin + if not Assigned(aArgs[unhidden].TypeInfo) then + args[i].ValueRef := Nil + else if aArgs[unhidden].Kind = tkDynArray then + args[i].ValueRef := PPointer(aArgs[unhidden].GetReferenceToRawData)^ + else + args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData; + end else + args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData; + + Inc(unhidden); + end; + end; + + flags := []; + if aStatic then + Include(flags, fcfStatic); + + mgr.Invoke(aCodeAddress, args, aCallConv, restype, resptr, flags); +end; + +function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback; +begin + if not Assigned(FuncCallMgr[aCallConv].CreateCallbackProc) then + raise ENotImplemented.Create(SErrCallbackNotImplented); + + if not Assigned(aHandler) then + raise EArgumentNilException.Create(SErrCallbackHandlerNil); + + Result := FuncCallMgr[aCallConv].CreateCallbackProc(aHandler, aCallConv, aArgs, aResultType, aFlags, aContext); +end; + +function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback; +begin + if not Assigned(FuncCallMgr[aCallConv].CreateCallbackMethod) then + raise ENotImplemented.Create(SErrCallbackNotImplented); + + if not Assigned(aHandler) then + raise EArgumentNilException.Create(SErrCallbackHandlerNil); + + Result := FuncCallMgr[aCallConv].CreateCallbackMethod(aHandler, aCallConv, aArgs, aResultType, aFlags, aContext); +end; + +function IsManaged(TypeInfo: PTypeInfo): boolean; +begin + if Assigned(TypeInfo) then + case TypeInfo^.Kind of + tkAString, + tkLString, + tkWString, + tkUString, + tkInterface, + tkVariant, + tkDynArray : Result := true; + tkArray : Result := IsManaged(GetTypeData(TypeInfo)^.ArrayData.ElType); + tkRecord, + tkObject : + with GetTypeData(TypeInfo)^.RecInitData^ do + Result := (ManagedFieldCount > 0) or Assigned(ManagementOp); + else + Result := false; + end + else + Result := false; +end; + +{$ifndef InLazIDE} +generic function OpenArrayToDynArrayValue(constref aArray: array of T): TValue; +var + arr: specialize TArray; + i: SizeInt; +begin + SetLength(arr, Length(aArray)); + for i := 0 to High(aArray) do + arr[i] := aArray[i]; + Result := TValue.specialize From>(arr); +end; +{$endif} + +{ TRttiPointerType } + +function TRttiPointerType.GetReferredType: TRttiType; +begin + Result := GRttiPool.GetType(FTypeData^.RefType); +end; + { TRttiRefCountedInterfaceType } function TRttiRefCountedInterfaceType.IntfData: PInterfaceData; @@ -1638,810 +2444,6 @@ begin result := FTypeData^.FloatType; end; -{ TValue } - -class function TValue.Empty: TValue; -begin - result.FData.FTypeInfo := nil; -{$if SizeOf(TMethod) > SizeOf(QWord)} - Result.FData.FAsMethod.Code := Nil; - Result.FData.FAsMethod.Data := Nil; -{$else} - Result.FData.FAsUInt64 := 0; -{$endif} -end; - -class procedure TValue.Make(ABuffer: pointer; ATypeInfo: PTypeInfo; out result: TValue); -type - PBoolean16 = ^Boolean16; - PBoolean32 = ^Boolean32; - PBoolean64 = ^Boolean64; - PByteBool = ^ByteBool; - PQWordBool = ^QWordBool; - PMethod = ^TMethod; -var - td: PTypeData; - size: SizeInt; -begin - result.FData.FTypeInfo:=ATypeInfo; - { resets the whole variant part; FValueData is already Nil } -{$if SizeOf(TMethod) > SizeOf(QWord)} - Result.FData.FAsMethod.Code := Nil; - Result.FData.FAsMethod.Data := Nil; -{$else} - Result.FData.FAsUInt64 := 0; -{$endif} - if not Assigned(ATypeInfo) then - Exit; - { first handle those types that need a TValueData implementation } - case ATypeInfo^.Kind of - tkSString : begin - td := GetTypeData(ATypeInfo); - result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, td^.MaxLength + 1, ATypeInfo, True); - end; - tkWString, - tkUString, - tkAString : result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True); - tkDynArray : result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True); - tkArray : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, Result.TypeData^.ArrayData.Size, ATypeInfo, False); - tkObject, - tkRecord : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, Result.TypeData^.RecSize, ATypeInfo, False); - tkInterface: result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True); - end; - if not Assigned(ABuffer) then - Exit; - { now handle those that are happy with the variant part of FData } - case ATypeInfo^.Kind of - tkSString, - tkWString, - tkUString, - tkAString, - tkDynArray, - tkArray, - tkObject, - tkRecord, - tkInterface: - { ignore } - ; - tkClass : result.FData.FAsObject := PPointer(ABuffer)^; - tkClassRef : result.FData.FAsClass := PClass(ABuffer)^; - tkInterfaceRaw : result.FData.FAsPointer := PPointer(ABuffer)^; - tkInt64 : result.FData.FAsSInt64 := PInt64(ABuffer)^; - tkQWord : result.FData.FAsUInt64 := PQWord(ABuffer)^; - tkProcVar : result.FData.FAsMethod.Code := PCodePointer(ABuffer)^; - tkMethod : result.FData.FAsMethod := PMethod(ABuffer)^; - tkPointer : result.FData.FAsPointer := PPointer(ABuffer)^; - tkSet : begin - td := GetTypeData(ATypeInfo); - case td^.OrdType of - otUByte: begin - { this can either really be 1 Byte or a set > 32-bit, so - check the underlying type } - if not (td^.CompType^.Kind in [tkInteger,tkEnumeration]) then - raise Exception.CreateFmt(SErrUnableToGetValueForType,[ATypeInfo^.Name]); - case td^.SetSize of - 0, 1: - Result.FData.FAsUByte := PByte(ABuffer)^; - { these two cases shouldn't happen, but better safe than sorry... } - 2: - Result.FData.FAsUWord := PWord(ABuffer)^; - 3, 4: - Result.FData.FAsULong := PLongWord(ABuffer)^; - { maybe we should also allow storage as otUQWord? } - 5..8: - Result.FData.FAsUInt64 := PQWord(ABuffer)^; - else - Result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, td^.SetSize, ATypeInfo, False); - end; - end; - otUWord: - Result.FData.FAsUWord := PWord(ABuffer)^; - otULong: - Result.FData.FAsULong := PLongWord(ABuffer)^; - else - { ehm... Panic? } - raise Exception.CreateFmt(SErrUnableToGetValueForType,[ATypeInfo^.Name]); - end; - end; - tkEnumeration, - tkInteger : begin - case GetTypeData(ATypeInfo)^.OrdType of - otSByte: result.FData.FAsSByte := PShortInt(ABuffer)^; - otUByte: result.FData.FAsUByte := PByte(ABuffer)^; - otSWord: result.FData.FAsSWord := PSmallInt(ABuffer)^; - otUWord: result.FData.FAsUWord := PWord(ABuffer)^; - otSLong: result.FData.FAsSLong := PLongInt(ABuffer)^; - otULong: result.FData.FAsULong := PLongWord(ABuffer)^; - end; - end; - tkBool : begin - case GetTypeData(ATypeInfo)^.OrdType of - otUByte: result.FData.FAsUByte := Byte(System.PBoolean(ABuffer)^); - otUWord: result.FData.FAsUWord := Word(PBoolean16(ABuffer)^); - otULong: result.FData.FAsULong := DWord(PBoolean32(ABuffer)^); - otUQWord: result.FData.FAsUInt64 := QWord(PBoolean64(ABuffer)^); - otSByte: result.FData.FAsSByte := ShortInt(PByteBool(ABuffer)^); - otSWord: result.FData.FAsSWord := SmallInt(PWordBool(ABuffer)^); - otSLong: result.FData.FAsSLong := LongInt(PLongBool(ABuffer)^); - otSQWord: result.FData.FAsSInt64 := Int64(PQWordBool(ABuffer)^); - end; - end; - tkFloat : begin - case GetTypeData(ATypeInfo)^.FloatType of - ftCurr : result.FData.FAsCurr := PCurrency(ABuffer)^; - ftSingle : result.FData.FAsSingle := PSingle(ABuffer)^; - ftDouble : result.FData.FAsDouble := PDouble(ABuffer)^; - ftExtended: result.FData.FAsExtended := PExtended(ABuffer)^; - ftComp : result.FData.FAsComp := PComp(ABuffer)^; - end; - end; - else - raise Exception.CreateFmt(SErrUnableToGetValueForType,[ATypeInfo^.Name]); - end; -end; - -class procedure TValue.MakeOpenArray(AArray: Pointer; ALength: SizeInt; ATypeInfo: PTypeInfo; out Result: TValue); -var - el: TValue; -begin - Result.FData.FTypeInfo := ATypeInfo; - { resets the whole variant part; FValueData is already Nil } -{$if SizeOf(TMethod) > SizeOf(QWord)} - Result.FData.FAsMethod.Code := Nil; - Result.FData.FAsMethod.Data := Nil; -{$else} - Result.FData.FAsUInt64 := 0; -{$endif} - if not Assigned(ATypeInfo) then - Exit; - if ATypeInfo^.Kind <> tkArray then - Exit; - if not Assigned(AArray) then - Exit; - if ALength < 0 then - Exit; - Result.FData.FValueData := TValueDataIntImpl.CreateRef(@AArray, ATypeInfo, False); - Result.FData.FArrLength := ALength; - Make(Nil, Result.TypeData^.ArrayData.ElType, el); - Result.FData.FElSize := el.DataSize; -end; - -{$ifndef NoGenericMethods} -generic class function TValue.From(constref aValue: T): TValue; -begin - TValue.Make(@aValue, System.TypeInfo(T), Result); -end; - -generic class function TValue.FromOpenArray(constref aValue: array of T): TValue; -var - arrdata: Pointer; -begin - if Length(aValue) > 0 then - arrdata := @aValue[0] - else - arrdata := Nil; - TValue.MakeOpenArray(arrdata, Length(aValue), System.TypeInfo(aValue), Result); -end; -{$endif} - -function TValue.GetTypeDataProp: PTypeData; -begin - result := GetTypeData(FData.FTypeInfo); -end; - -function TValue.GetDataSize: SizeInt; -begin - if Assigned(FData.FValueData) and (Kind <> tkSString) then - Result := FData.FValueData.GetDataSize - else begin - Result := 0; - case Kind of - tkEnumeration, - tkBool, - tkInt64, - tkQWord, - tkInteger: - case TypeData^.OrdType of - otSByte, - otUByte: - Result := SizeOf(Byte); - otSWord, - otUWord: - Result := SizeOf(Word); - otSLong, - otULong: - Result := SizeOf(LongWord); - otSQWord, - otUQWord: - Result := SizeOf(QWord); - end; - tkChar: - Result := SizeOf(AnsiChar); - tkFloat: - case TypeData^.FloatType of - ftSingle: - Result := SizeOf(Single); - ftDouble: - Result := SizeOf(Double); - ftExtended: - Result := SizeOf(Extended); - ftComp: - Result := SizeOf(Comp); - ftCurr: - Result := SizeOf(Currency); - end; - tkSet: - Result := TypeData^.SetSize; - tkMethod: - Result := SizeOf(TMethod); - tkSString: - { ShortString can hold max. 254 characters as [0] is Length and [255] is #0 } - Result := SizeOf(ShortString) - 2; - tkVariant: - Result := SizeOf(Variant); - tkProcVar: - Result := SizeOf(CodePointer); - tkWChar: - Result := SizeOf(WideChar); - tkUChar: - Result := SizeOf(UnicodeChar); - tkFile: - { ToDo } - Result := SizeOf(TTextRec); - tkAString, - tkWString, - tkUString, - tkInterface, - tkDynArray, - tkClass, - tkHelper, - tkClassRef, - tkInterfaceRaw, - tkPointer: - Result := SizeOf(Pointer); - tkObject, - tkRecord: - Result := TypeData^.RecSize; - tkArray: - Result := TypeData^.ArrayData.Size; - tkUnknown, - tkLString: - Assert(False); - end; - end; -end; - -function TValue.GetTypeInfo: PTypeInfo; -begin - result := FData.FTypeInfo; -end; - -function TValue.GetTypeKind: TTypeKind; -begin - if not Assigned(FData.FTypeInfo) then - Result := tkUnknown - else - result := FData.FTypeInfo^.Kind; -end; - -function TValue.GetIsEmpty: boolean; -begin - result := (FData.FTypeInfo=nil) or - ((Kind in [tkSString, tkObject, tkRecord, tkArray]) and not Assigned(FData.FValueData)) or - ((Kind in [tkClass, tkClassRef, tkInterfaceRaw]) and not Assigned(FData.FAsPointer)); -end; - -function TValue.IsArray: boolean; -begin - result := kind in [tkArray, tkDynArray]; -end; - -function TValue.IsOpenArray: Boolean; -var - td: PTypeData; -begin - td := TypeData; - Result := (Kind = tkArray) and (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) -end; - -function TValue.AsString: string; -begin - if System.GetTypeKind(String) = tkUString then - Result := String(AsUnicodeString) - else - Result := String(AsAnsiString); -end; - -function TValue.AsUnicodeString: UnicodeString; -begin - if (Kind in [tkSString, tkAString, tkUString, tkWString]) and not Assigned(FData.FValueData) then - Result := '' - else - case Kind of - tkSString: - Result := UnicodeString(PShortString(FData.FValueData.GetReferenceToRawData)^); - tkAString: - Result := UnicodeString(PAnsiString(FData.FValueData.GetReferenceToRawData)^); - tkWString: - Result := UnicodeString(PWideString(FData.FValueData.GetReferenceToRawData)^); - tkUString: - Result := UnicodeString(PUnicodeString(FData.FValueData.GetReferenceToRawData)^); - else - raise EInvalidCast.Create(SErrInvalidTypecast); - end; -end; - -function TValue.AsAnsiString: AnsiString; -begin - if (Kind in [tkSString, tkAString, tkUString, tkWString]) and not Assigned(FData.FValueData) then - Result := '' - else - case Kind of - tkSString: - Result := AnsiString(PShortString(FData.FValueData.GetReferenceToRawData)^); - tkAString: - Result := AnsiString(PAnsiString(FData.FValueData.GetReferenceToRawData)^); - tkWString: - Result := AnsiString(PWideString(FData.FValueData.GetReferenceToRawData)^); - tkUString: - Result := AnsiString(PUnicodeString(FData.FValueData.GetReferenceToRawData)^); - else - raise EInvalidCast.Create(SErrInvalidTypecast); - end; -end; - -function TValue.AsExtended: Extended; -begin - if Kind = tkFloat then - begin - case TypeData^.FloatType of - ftSingle : result := FData.FAsSingle; - ftDouble : result := FData.FAsDouble; - ftExtended : result := FData.FAsExtended; - ftCurr : result := FData.FAsCurr; - ftComp : result := FData.FAsComp; - else - raise EInvalidCast.Create(SErrInvalidTypecast); - end; - end - else - raise EInvalidCast.Create(SErrInvalidTypecast); -end; - -function TValue.AsObject: TObject; -begin - if IsObject or (IsClass and not Assigned(FData.FAsObject)) then - result := TObject(FData.FAsObject) - else - raise EInvalidCast.Create(SErrInvalidTypecast); -end; - -function TValue.IsObject: boolean; -begin - result := (Kind = tkClass) or ((Kind = tkUnknown) and not Assigned(FData.FAsObject)); -end; - -function TValue.IsClass: boolean; -begin - result := (Kind = tkClassRef) or ((Kind in [tkClass,tkUnknown]) and not Assigned(FData.FAsObject)); -end; - -function TValue.AsClass: TClass; -begin - if IsClass then - result := FData.FAsClass - else - raise EInvalidCast.Create(SErrInvalidTypecast); -end; - -function TValue.IsOrdinal: boolean; -begin - result := (Kind in [tkInteger, tkInt64, tkQWord, tkBool]) or - ((Kind in [tkClass, tkClassRef, tkInterfaceRaw, tkUnknown]) and not Assigned(FData.FAsPointer)); -end; - -function TValue.AsBoolean: boolean; -begin - if (Kind = tkBool) then - case TypeData^.OrdType of - otSByte: Result := ByteBool(FData.FAsSByte); - otUByte: Result := Boolean(FData.FAsUByte); - otSWord: Result := WordBool(FData.FAsSWord); - otUWord: Result := Boolean16(FData.FAsUWord); - otSLong: Result := LongBool(FData.FAsSLong); - otULong: Result := Boolean32(FData.FAsULong); - otSQWord: Result := QWordBool(FData.FAsSInt64); - otUQWord: Result := Boolean64(FData.FAsUInt64); - end - else - raise EInvalidCast.Create(SErrInvalidTypecast); -end; - -function TValue.AsOrdinal: Int64; -begin - if IsOrdinal then - if Kind in [tkClass, tkClassRef, tkInterfaceRaw, tkUnknown] then - Result := 0 - else - case TypeData^.OrdType of - otSByte: Result := FData.FAsSByte; - otUByte: Result := FData.FAsUByte; - otSWord: Result := FData.FAsSWord; - otUWord: Result := FData.FAsUWord; - otSLong: Result := FData.FAsSLong; - otULong: Result := FData.FAsULong; - otSQWord: Result := FData.FAsSInt64; - otUQWord: Result := FData.FAsUInt64; - end - else - raise EInvalidCast.Create(SErrInvalidTypecast); -end; - -function TValue.AsCurrency: Currency; -begin - if (Kind = tkFloat) and (TypeData^.FloatType=ftCurr) then - result := FData.FAsCurr - else - raise EInvalidCast.Create(SErrInvalidTypecast); -end; - -function TValue.AsInteger: Integer; -begin - if Kind in [tkInteger, tkInt64, tkQWord] then - case TypeData^.OrdType of - otSByte: Result := FData.FAsSByte; - otUByte: Result := FData.FAsUByte; - otSWord: Result := FData.FAsSWord; - otUWord: Result := FData.FAsUWord; - otSLong: Result := FData.FAsSLong; - otULong: Result := FData.FAsULong; - otSQWord: Result := FData.FAsSInt64; - otUQWord: Result := FData.FAsUInt64; - end - else - raise EInvalidCast.Create(SErrInvalidTypecast); -end; - -function TValue.AsInt64: Int64; -begin - if Kind in [tkInteger, tkInt64, tkQWord] then - case TypeData^.OrdType of - otSByte: Result := FData.FAsSByte; - otUByte: Result := FData.FAsUByte; - otSWord: Result := FData.FAsSWord; - otUWord: Result := FData.FAsUWord; - otSLong: Result := FData.FAsSLong; - otULong: Result := FData.FAsULong; - otSQWord: Result := FData.FAsSInt64; - otUQWord: Result := FData.FAsUInt64; - end - else if (Kind = tkFloat) and (TypeData^.FloatType = ftComp) then - Result := Int64(FData.FAsComp) - else - raise EInvalidCast.Create(SErrInvalidTypecast); -end; - -function TValue.AsUInt64: QWord; -begin - if Kind in [tkInteger, tkInt64, tkQWord] then - case TypeData^.OrdType of - otSByte: Result := FData.FAsSByte; - otUByte: Result := FData.FAsUByte; - otSWord: Result := FData.FAsSWord; - otUWord: Result := FData.FAsUWord; - otSLong: Result := FData.FAsSLong; - otULong: Result := FData.FAsULong; - otSQWord: Result := FData.FAsSInt64; - otUQWord: Result := FData.FAsUInt64; - end - else if (Kind = tkFloat) and (TypeData^.FloatType = ftComp) then - Result := QWord(FData.FAsComp) - else - raise EInvalidCast.Create(SErrInvalidTypecast); -end; - -function TValue.AsInterface: IInterface; -begin - if Kind = tkInterface then - Result := PInterface(FData.FValueData.GetReferenceToRawData)^ - else if (Kind in [tkClass, tkClassRef, tkUnknown]) and not Assigned(FData.FAsPointer) then - Result := Nil - else - raise EInvalidCast.Create(SErrInvalidTypecast); -end; - -function TValue.ToString: String; -begin - case Kind of - tkWString, - tkUString : result := AsUnicodeString; - tkSString, - tkAString : result := AsAnsiString; - tkInteger : result := IntToStr(AsInteger); - tkQWord : result := IntToStr(AsUInt64); - tkInt64 : result := IntToStr(AsInt64); - tkBool : result := BoolToStr(AsBoolean, True); - else - result := ''; - end; -end; - -function TValue.GetArrayLength: SizeInt; -var - td: PTypeData; -begin - if not IsArray then - raise EInvalidCast.Create(SErrInvalidTypecast); - if Kind = tkDynArray then - Result := DynArraySize(PPointer(FData.FValueData.GetReferenceToRawData)^) - else begin - td := TypeData; - if (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) then - Result := FData.FArrLength - else - Result := td^.ArrayData.ElCount; - end; -end; - -function TValue.GetArrayElement(AIndex: SizeInt): TValue; -var - data: Pointer; - eltype: PTypeInfo; - elsize: SizeInt; - td: PTypeData; -begin - if not IsArray then - raise EInvalidCast.Create(SErrInvalidTypecast); - if Kind = tkDynArray then begin - data := DynArrayIndex(PPointer(FData.FValueData.GetReferenceToRawData)^, [AIndex], FData.FTypeInfo); - eltype := TypeData^.elType2; - end else begin - td := TypeData; - eltype := td^.ArrayData.ElType; - { open array? } - if (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) then begin - data := PPointer(FData.FValueData.GetReferenceToRawData)^; - elsize := FData.FElSize - end else begin - data := FData.FValueData.GetReferenceToRawData; - elsize := td^.ArrayData.Size div td^.ArrayData.ElCount; - end; - data := PByte(data) + AIndex * elsize; - end; - { MakeWithoutCopy? } - Make(data, eltype, Result); -end; - -procedure TValue.SetArrayElement(AIndex: SizeInt; constref AValue: TValue); -var - data: Pointer; - eltype: PTypeInfo; - elsize: SizeInt; - td, tdv: PTypeData; -begin - if not IsArray then - raise EInvalidCast.Create(SErrInvalidTypecast); - if Kind = tkDynArray then begin - data := DynArrayIndex(PPointer(FData.FValueData.GetReferenceToRawData)^, [AIndex], FData.FTypeInfo); - eltype := TypeData^.elType2; - end else begin - td := TypeData; - eltype := td^.ArrayData.ElType; - { open array? } - if (td^.ArrayData.Size = 0) and (td^.ArrayData.ElCount = 0) then begin - data := PPointer(FData.FValueData.GetReferenceToRawData)^; - elsize := FData.FElSize - end else begin - data := FData.FValueData.GetReferenceToRawData; - elsize := td^.ArrayData.Size div td^.ArrayData.ElCount; - end; - data := PByte(data) + AIndex * elsize; - end; - { maybe we'll later on allow some typecasts, but for now be restrictive } - if eltype^.Kind <> AValue.Kind then - raise EInvalidCast.Create(SErrInvalidTypecast); - td := GetTypeData(eltype); - tdv := AValue.TypeData; - if ((eltype^.Kind in [tkInteger, tkBool, tkEnumeration, tkSet]) and (td^.OrdType <> tdv^.OrdType)) or - ((eltype^.Kind = tkFloat) and (td^.FloatType <> tdv^.FloatType)) then - raise EInvalidCast.Create(SErrInvalidTypecast); - if Assigned(AValue.FData.FValueData) and (eltype^.Kind <> tkSString) then - IntCopy(AValue.FData.FValueData.GetReferenceToRawData, data, eltype) - else - Move(AValue.GetReferenceToRawData^, data^, AValue.DataSize); -end; - -function TValue.IsType(ATypeInfo: PTypeInfo): boolean; -begin - result := ATypeInfo = TypeInfo; -end; - -function TValue.TryAsOrdinal(out AResult: int64): boolean; -begin - result := IsOrdinal; - if result then - AResult := AsOrdinal; -end; - -function TValue.GetReferenceToRawData: Pointer; -begin - if not Assigned(FData.FTypeInfo) then - Result := Nil - else if Assigned(FData.FValueData) then - Result := FData.FValueData.GetReferenceToRawData - else begin - Result := Nil; - case Kind of - tkInteger, - tkEnumeration, - tkInt64, - tkQWord, - tkBool: - case TypeData^.OrdType of - otSByte: - Result := @FData.FAsSByte; - otUByte: - Result := @FData.FAsUByte; - otSWord: - Result := @FData.FAsSWord; - otUWord: - Result := @FData.FAsUWord; - otSLong: - Result := @FData.FAsSLong; - otULong: - Result := @FData.FAsULong; - otSQWord: - Result := @FData.FAsSInt64; - otUQWord: - Result := @FData.FAsUInt64; - end; - tkSet: begin - case TypeData^.OrdType of - otUByte: begin - case TypeData^.SetSize of - 1: - Result := @FData.FAsUByte; - 2: - Result := @FData.FAsUWord; - 3, 4: - Result := @FData.FAsULong; - 5..8: - Result := @FData.FAsUInt64; - else - { this should have gone through FAsValueData :/ } - Result := Nil; - end; - end; - otUWord: - Result := @FData.FAsUWord; - otULong: - Result := @FData.FAsULong; - else - Result := Nil; - end; - end; - tkChar: - Result := @FData.FAsUByte; - tkFloat: - case TypeData^.FloatType of - ftSingle: - Result := @FData.FAsSingle; - ftDouble: - Result := @FData.FAsDouble; - ftExtended: - Result := @FData.FAsExtended; - ftComp: - Result := @FData.FAsComp; - ftCurr: - Result := @FData.FAsCurr; - end; - tkMethod: - Result := @FData.FAsMethod; - tkClass: - Result := @FData.FAsObject; - tkWChar: - Result := @FData.FAsUWord; - tkInterfaceRaw: - Result := @FData.FAsPointer; - tkProcVar: - Result := @FData.FAsMethod.Code; - tkUChar: - Result := @FData.FAsUWord; - tkFile: - Result := @FData.FAsPointer; - tkClassRef: - Result := @FData.FAsClass; - tkPointer: - Result := @FData.FAsPointer; - tkVariant, - tkDynArray, - tkArray, - tkObject, - tkRecord, - tkInterface, - tkSString, - tkLString, - tkAString, - tkUString, - tkWString: - Assert(false, 'Managed/complex type not handled through IValueData'); - end; - end; -end; - -procedure TValue.ExtractRawData(ABuffer: Pointer); -begin - if Assigned(FData.FValueData) then - FData.FValueData.ExtractRawData(ABuffer) - else if Assigned(FData.FTypeInfo) then - Move((@FData.FAsPointer)^, ABuffer^, DataSize); -end; - -procedure TValue.ExtractRawDataNoCopy(ABuffer: Pointer); -begin - if Assigned(FData.FValueData) then - FData.FValueData.ExtractRawDataNoCopy(ABuffer) - else if Assigned(FData.FTypeInfo) then - Move((@FData.FAsPointer)^, ABuffer^, DataSize); -end; - -class operator TValue.:=(const AValue: String): TValue; -begin - Make(@AValue, System.TypeInfo(AValue), Result); -end; - -class operator TValue.:=(AValue: LongInt): TValue; -begin - Make(@AValue, System.TypeInfo(AValue), Result); -end; - -class operator TValue.:=(AValue: Single): TValue; -begin - Make(@AValue, System.TypeInfo(AValue), Result); -end; - -class operator TValue.:=(AValue: Double): TValue; -begin - Make(@AValue, System.TypeInfo(AValue), Result); -end; - -{$ifdef FPC_HAS_TYPE_EXTENDED} -class operator TValue.:=(AValue: Extended): TValue; -begin - Make(@AValue, System.TypeInfo(AValue), Result); -end; -{$endif} - -class operator TValue.:=(AValue: Currency): TValue; -begin - Make(@AValue, System.TypeInfo(AValue), Result); -end; - -class operator TValue.:=(AValue: Int64): TValue; -begin - Make(@AValue, System.TypeInfo(AValue), Result); -end; - -class operator TValue.:=(AValue: QWord): TValue; -begin - Make(@AValue, System.TypeInfo(AValue), Result); -end; - -class operator TValue.:=(AValue: TObject): TValue; -begin - Make(@AValue, System.TypeInfo(AValue), Result); -end; - -class operator TValue.:=(AValue: TClass): TValue; -begin - Make(@AValue, System.TypeInfo(AValue), Result); -end; - -class operator TValue.:=(AValue: Boolean): TValue; -begin - Make(@AValue, System.TypeInfo(AValue), Result); -end; - { TRttiParameter } function TRttiParameter.ToString: String; @@ -2598,6 +2600,11 @@ begin Result := False; end; +function TRttiMethod.GetParameters: specialize TArray; +begin + Result := GetParameters(False); +end; + function TRttiMethod.ToString: String; var ret: TRttiType; @@ -2649,11 +2656,6 @@ begin Result := FString; end; -function TRttiMethod.GetParameters: specialize TArray; -begin - Result := GetParameters(False); -end; - function TRttiMethod.Invoke(aInstance: TObject; const aArgs: array of TValue): TValue; var instance: TValue; @@ -3551,7 +3553,7 @@ begin end;} {$ifndef InLazIDE} -{$if defined(CPUX86_64) and defined(WIN64)} +{$if defined(CPUI386) or (defined(CPUX86_64) and defined(WIN64))} {$I invoke.inc} {$endif} {$endif} diff --git a/packages/rtl-objpas/src/x86_64/invoke.inc b/packages/rtl-objpas/src/x86_64/invoke.inc index 057aa8b86f..b64c2a780c 100644 --- a/packages/rtl-objpas/src/x86_64/invoke.inc +++ b/packages/rtl-objpas/src/x86_64/invoke.inc @@ -93,6 +93,7 @@ begin Result := False; if Assigned(aType) then begin case aType^.Kind of + tkMethod, tkSString, tkAString, tkUString, @@ -290,11 +291,423 @@ begin {$endif} end; +{$ifdef windows} +const + PlaceholderContext = QWord($1234567812345678); + PlaceholderAddress = QWord($8765432187654321); + +label + CallbackContext, + CallbackAddress, + CallbackCall, + CallbackEnd; + +const + CallbackContextPtr: Pointer = @CallbackContext; + CallbackAddressPtr: Pointer = @CallbackAddress; + CallbackCallPtr: Pointer = @CallbackCall; + CallbackEndPtr: Pointer = @CallbackEnd; + +procedure Callback; assembler; nostackframe; +asm + { store integer registers } + + movq %rcx, 8(%rsp) +.seh_savereg %rcx, 8 + movq %rdx, 16(%rsp) +.seh_savereg %rdx, 16 + movq %r8, 24(%rsp) +.seh_savereg %r8, 24 + movq %r9, 32(%rsp) +.seh_savereg %r9, 32 + + { establish frame } + pushq %rbp +.seh_pushreg %rbp + movq %rsp, %rbp +.seh_setframe %rbp, 0 +.seh_endprologue + + { store pointer to stack area (including GP registers) } + lea 16(%rsp), %rdx + + sub $32, %rsp + movq %xmm0, (%rsp) + movq %xmm1, 8(%rsp) + movq %xmm2, 16(%rsp) + movq %xmm3, 24(%rsp) + + { store pointer to FP registers } + movq %rsp, %r8 + + sub $32, %rsp + + { call function with context } +CallbackContext: + movq $0x1234567812345678, %rcx +CallbackAddress: + movq $0x8765432187654321, %rax +CallbackCall: + + call *%rax + + { duplicate result to SSE result register } + movq %rax, %xmm0 + + { restore stack } + movq %rbp, %rsp + popq %rbp + + ret +CallbackEnd: +end; +{$endif} + +type + TSystemFunctionCallback = class(TFunctionCallCallback) + {$ifdef windows} + private type + {$ScopedEnums On} + TArgType = ( + GenReg, + FPReg, + Stack + ); + {$ScopedEnums Off} + + TArgInfo = record + ArgType: TArgType; + Offset: SizeInt; + Deref: Boolean; + end; + private + fData: Pointer; + fSize: PtrUInt; + fFlags: TFunctionCallFlags; + fContext: Pointer; + fArgs: specialize TArray; + fArgInfos: specialize TArray; + fRefArgs: specialize TArray; + fResultType: PTypeInfo; + fResultIdx: SizeInt; + fResultInParam: Boolean; + private + function Handler(aStack, aFP: Pointer): PtrUInt; + protected + procedure CreateCallback; + procedure CreateArgInfos; + function GetCodeAddress: CodePointer; override; + {$endif} + procedure CallHandler(constref aArgs: specialize TArray; aResult: Pointer; aContext: Pointer); virtual; abstract; + public + constructor Create(aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags); + destructor Destroy; override; + end; + + TSystemFunctionCallbackMethod = class(TSystemFunctionCallback) + private + fHandler: TFunctionCallMethod; + protected + procedure CallHandler(constref aArgs: specialize TArray; aResult: Pointer; aContext: Pointer); override; + public + constructor Create(aHandler: TFunctionCallMethod; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags); + end; + + TSystemFunctionCallbackProc = class(TSystemFunctionCallback) + private + fHandler: TFunctionCallProc; + protected + procedure CallHandler(constref aArgs: specialize TArray; aResult: Pointer; aContext: Pointer); override; + public + constructor Create(aHandler: TFunctionCallProc; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags); + end; + +{$ifdef windows} +function TSystemFunctionCallback.Handler(aStack, aFP: Pointer): PtrUInt; +var + args: specialize TArray; + i, len: SizeInt; + val: PPtrUInt; + resptr: Pointer; +begin + len := Length(fArgInfos); + if fResultInParam then + Dec(len); + SetLength(args, len); + for i := 0 to High(fArgInfos) do begin + if i = fResultIdx then + Continue; + case fArgInfos[i].ArgType of + TArgType.GenReg, + TArgType.Stack: + val := @PPtrUInt(aStack)[fArgInfos[i].Offset]; + TArgType.FPReg: + val := @PPtrUInt(aFP)[fArgInfos[i].Offset]; + end; + if fArgInfos[i].Deref then + args[i] := PPtrUInt(val^) + else + args[i] := val; + end; + + if fResultInParam then begin + case fArgInfos[fResultIdx].ArgType of + TArgType.GenReg, + TArgType.Stack: + resptr := @PPtrUInt(aStack)[fArgInfos[fResultIdx].Offset]; + TArgType.FPReg: + resptr := @PPtrUInt(aFP)[fArgInfos[fResultIdx].Offset]; + end; + if fArgInfos[fResultIdx].Deref then + resptr := PPointer(resptr)^; + end else + resptr := @Result; + + CallHandler(args, resptr, fContext); +end; + +procedure TSystemFunctionCallback.CreateCallback; + + procedure ReplacePlaceholder(aPlaceholder: PtrUInt; aValue: PtrUInt; aOfs, aSize: PtrUInt); + var + found: Boolean; + i: PtrUInt; + begin + found := False; + for i := aOfs to aOfs + aSize - 1 do begin + if PPtrUInt(@PByte(fData)[i])^ = PtrUInt(aPlaceholder) then begin + PPtrUInt(@(PByte(fData)[i]))^ := PtrUInt(aValue); + found := True; + Break; + end; + end; + + if not found then + raise Exception.Create(SErrMethodImplCreateFailed); + end; + +var + src: Pointer; + ofs, size: PtrUInt; + method: TMethod; +begin + fSize := PtrUInt(CallbackEndPtr) - PtrUInt(@Callback) + 1; + fData := AllocateMemory(fSize); + if not Assigned(fData) then + raise Exception.Create(SErrMethodImplCreateFailed); + + src := @Callback; + Move(src^, fData^, fSize); + + ofs := PtrUInt(CallbackContextPtr) - PtrUInt(@Callback); + size := PtrUInt(CallbackAddressPtr) - PtrUInt(CallbackContextPtr); + + method := TMethod(@Handler); + + ReplacePlaceholder(PlaceholderContext, PtrUInt(method.Data), ofs, size); + + ofs := PtrUInt(CallbackAddressPtr) - PtrUInt(@Callback); + size := PtrUInt(CallbackCallPtr) - PtrUInt(CallbackAddressPtr); + + ReplacePlaceholder(PlaceholderAddress, PtrUInt(method.Code), ofs, size); + + if not ProtectMemory(fData, fSize, True) then + raise Exception.Create(SErrMethodImplCreateFailed); +end; + +procedure TSystemFunctionCallback.CreateArgInfos; +type + PBoolean16 = ^Boolean16; + PBoolean32 = ^Boolean32; + PBoolean64 = ^Boolean64; + PByteBool = ^ByteBool; + PQWordBool = ^QWordBool; +var + stackarea: array of PtrUInt; + stackptr: Pointer; + regs: array[0..3] of PtrUInt; + i, argidx, ofs: LongInt; + val: PtrUInt; + td: PTypeData; + argcount, resreg, refargs: SizeInt; +begin + fResultInParam := ReturnResultInParam(fResultType); + + ofs := 0; + argidx := 0; + refargs := 0; + argcount := Length(fArgs); + if fResultInParam then begin + if fcfStatic in fFlags then + fResultIdx := 0 + else + fResultIdx := 1; + Inc(argcount); + end else + fResultIdx := -1; + SetLength(fArgInfos, argcount); + SetLength(fRefArgs, argcount); + if fResultIdx >= 0 then begin + fArgInfos[fResultIdx].ArgType := TArgType.GenReg; + fArgInfos[fResultIdx].Offset := fResultIdx; + end; + for i := 0 to High(fArgs) do begin + if argidx = fResultIdx then + Inc(argidx); + if pfResult in fArgs[i].ParamFlags then begin + fResultIdx := argidx; + fResultInParam := True; + end; + fArgInfos[argidx].ArgType := TArgType.GenReg; + fArgInfos[argidx].Deref := False; + if pfArray in fArgs[i].ParamFlags then + fArgInfos[argidx].Deref := True + else if fArgs[i].ParamFlags * [pfOut, pfVar, pfConstRef] <> [] then + fArgInfos[argidx].Deref := True + else begin + td := GetTypeData(fArgs[i].ParamType); + case fArgs[i].ParamType^.Kind of + tkSString, + tkMethod: + fArgInfos[argidx].Deref := True; + tkArray: + if not (td^.ArrayData.Size in [1, 2, 4, 8]) then + fArgInfos[argidx].Deref := True; + tkRecord: + if not (td^.RecSize in [1, 2, 4, 8]) then + fArgInfos[argidx].Deref := True; + { ToDo: handle object like record? } + tkObject, + tkWString, + tkUString, + tkAString, + tkDynArray, + tkClass, + tkClassRef, + tkInterface, + tkInterfaceRaw, + tkProcVar, + tkPointer: + ; + tkInt64, + tkQWord: + ; + tkSet: begin + case td^.OrdType of + otUByte: begin + case td^.SetSize of + 0, 1, 2, 4, 8: + ; + else + fArgInfos[argidx].Deref := True; + end; + end; + otUWord, + otULong: + ; + end; + end; + tkEnumeration, + tkInteger, + tkBool: + ; + tkFloat: begin + case td^.FloatType of + ftCurr, + ftComp: + ; + ftSingle, + ftDouble : fArgInfos[argidx].ArgType := TArgType.FPReg; + ftExtended: {val := PInt64(PExtended(aArgs[i].ValueRef))^}; + end; + end; + else + raise EInvocationError.CreateFmt(SErrFailedToConvertArg, [i, fArgs[i].ParamType^.Name]); + end; + end; + + if (fArgInfos[argidx].ArgType = TArgType.FPReg) and (ofs >= 4) then + fArgInfos[argidx].ArgType := TArgType.Stack; + if (fArgInfos[argidx].ArgType = TArgType.GenReg) and (ofs >= 4) then + fArgInfos[argidx].ArgType := TArgType.Stack; + + fArgInfos[argidx].Offset := ofs; + Inc(ofs); + Inc(argidx); + end; +end; + +function TSystemFunctionCallback.GetCodeAddress: CodePointer; +begin + Result := fData; +end; +{$endif} + +constructor TSystemFunctionCallback.Create(aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags); +{$ifdef windows} +var + i: SizeInt; +{$endif} +begin +{$ifdef windows} + fContext := aContext; + SetLength(fArgs, Length(aArgs)); + for i := 0 to High(aArgs) do + fArgs[i] := aArgs[i]; + fResultType := aResultType; + fFlags := aFlags; + CreateCallback; + CreateArgInfos; +{$else} + raise EInvocationError.Create(SErrPlatformNotSupported); +{$endif} +end; + +destructor TSystemFunctionCallback.Destroy; +begin +{$ifdef windows} + if Assigned(fData) then + FreeMemory(fData); +{$endif} +end; + +constructor TSystemFunctionCallbackProc.Create(aHandler: TFunctionCallProc; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags); +begin + inherited Create(aContext, aCallConv, aArgs, aResultType, aFlags); + fHandler := aHandler; +end; + +procedure TSystemFunctionCallbackProc.CallHandler(constref aArgs: specialize TArray; aResult: Pointer; aContext: Pointer); +begin + fHandler(aArgs, aResult, aContext); +end; + +constructor TSystemFunctionCallbackMethod.Create(aHandler: TFunctionCallMethod; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags); +begin + inherited Create(aContext, aCallConv, aArgs, aResultType, aFlags); + fHandler := aHandler; +end; + +procedure TSystemFunctionCallbackMethod.CallHandler(constref aArgs: specialize TArray; aResult: Pointer; aContext: Pointer); +begin + fHandler(aArgs, aResult, aContext); +end; + +function SystemCreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback; +begin + Result := TSystemFunctionCallbackProc.Create(aHandler, aContext, aCallConv, aArgs, aResultType, aFlags); +end; + +function SystemCreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback; +begin + Result := TSystemFunctionCallbackMethod.Create(aHandler, aContext, aCallConv, aArgs, aResultType, aFlags); +end; + const SystemFunctionCallManager: TFunctionCallManager = ( Invoke: @SystemInvoke; - CreateCallbackProc: Nil; - CreateCallbackMethod: Nil; + CreateCallbackProc: @SystemCreateCallbackProc; + CreateCallbackMethod: @SystemCreateCallbackMethod; ); procedure InitSystemFunctionCallManager; diff --git a/packages/rtl-objpas/tests/testrunner.rtlobjpas.pp b/packages/rtl-objpas/tests/testrunner.rtlobjpas.pp index 90ddc3b891..fc5d6a48d8 100644 --- a/packages/rtl-objpas/tests/testrunner.rtlobjpas.pp +++ b/packages/rtl-objpas/tests/testrunner.rtlobjpas.pp @@ -8,6 +8,8 @@ program testrunner.rtlobjpas; {.$define useffi} {$if defined(CPUX64) and defined(WINDOWS)} {$define testinvoke} +{$elseif defined(CPUI386)} +{$define testinvoke} {$else} {$ifdef useffi} {$define testinvoke} diff --git a/packages/rtl-objpas/tests/tests.rtti.pas b/packages/rtl-objpas/tests/tests.rtti.pas index 1c0ee88d78..1a32e412f1 100644 --- a/packages/rtl-objpas/tests/tests.rtti.pas +++ b/packages/rtl-objpas/tests/tests.rtti.pas @@ -604,7 +604,7 @@ begin CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); - Check(v.AsExtended=fcu); + Check(v.AsExtended=Extended(fcu)); Check(v.AsCurrency=fcu); Check(v.GetReferenceToRawData <> @fcu); @@ -643,7 +643,7 @@ begin CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); - Check(v.AsExtended=fco); + Check(v.AsExtended=Extended(fco)); Check(v.GetReferenceToRawData <> @fco); try diff --git a/packages/rtl-objpas/tests/tests.rtti.util.pas b/packages/rtl-objpas/tests/tests.rtti.util.pas index 358a32894b..da780e8e56 100644 --- a/packages/rtl-objpas/tests/tests.rtti.util.pas +++ b/packages/rtl-objpas/tests/tests.rtti.util.pas @@ -37,7 +37,7 @@ function GetArray(const aArg: array of SizeInt): TValue; implementation uses - TypInfo, SysUtils; + TypInfo, SysUtils, Math; {$ifndef fpc} function TValueHelper.AsUnicodeString: UnicodeString; @@ -124,10 +124,12 @@ begin Result := False else begin case td1^.FloatType of - ftSingle, - ftDouble, + ftSingle: + Result := SameValue(Single(aValue1.AsExtended), Single(aValue2.AsExtended)); + ftDouble: + Result := SameValue(Double(aValue1.AsExtended), Double(aValue2.AsExtended)); ftExtended: - Result := aValue1.AsExtended = aValue2.AsExtended; + Result := SameValue(aValue1.AsExtended, aValue2.AsExtended); ftComp: Result := aValue1.AsInt64 = aValue2.AsInt64; ftCurr: diff --git a/tests/test/trtti15.pp b/tests/test/trtti15.pp index f14231a358..86fbdc45d7 100644 --- a/tests/test/trtti15.pp +++ b/tests/test/trtti15.pp @@ -24,6 +24,7 @@ type function Test7(arg1: LongInt; arg2: String): String; pascal; {$endif} function Test8(arg1: LongInt; arg2: String): String; cdecl; + procedure Test9(var arg1; out arg2; constref arg3); property T: LongInt read Test2; property T2: LongInt read Test2; end; @@ -52,10 +53,15 @@ begin ErrorHalt('Expected parameter name %s, but got %s', [aName, aParam^.Name]); if aParam^.Flags <> aFlags then ErrorHalt('Expected parameter flags %s, but got %s', [HexStr(Word(aFlags), 4), HexStr(Word(aParam^.Flags), 4)]); - if not Assigned(aParam^.ParamType) then - ErrorHalt('Expected parameter type %s, but got Nil', [aTypeInfo^.Name]); - if aParam^.ParamType^ <> aTypeInfo then - ErrorHalt('Expected parameter type %s, but got %s', [aTypeInfo^.Name, aParam^.ParamType^^.Name]); + if Assigned(aTypeInfo) then begin + if not Assigned(aParam^.ParamType) then + ErrorHalt('Expected parameter type %s, but got Nil', [aTypeInfo^.Name]); + if aParam^.ParamType^ <> aTypeInfo then + ErrorHalt('Expected parameter type %s, but got %s', [aTypeInfo^.Name, aParam^.ParamType^^.Name]); + end else begin + if Assigned(aParam^.ParamType) then + ErrorHalt('Expected Nil parameter type, but got %s', [aParam^.ParamType^^.Name]) + end; end; type @@ -218,6 +224,12 @@ begin MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest)), MakeParam('arg1', [], TypeInfo(LongInt)), MakeParam('arg2', [], TypeInfo(String)) + ]), + MakeMethod('Test9', DefaultCallingConvention, mkProcedure, Nil, [ + MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest)), + MakeParam('arg1', [pfVar], Nil), + MakeParam('arg2', [pfOut], Nil), + MakeParam('arg3', [pfConstRef], Nil) ]) ]); end. diff --git a/tests/test/trtti19.pp b/tests/test/trtti19.pp new file mode 100644 index 0000000000..046e900718 --- /dev/null +++ b/tests/test/trtti19.pp @@ -0,0 +1,77 @@ +program trtti19; + +{$mode objfpc} + +uses + TypInfo; + +type + TTestProc = procedure(var arg1; out arg2; constref arg3); + TTestMethod = procedure(var arg1; out arg2; constref arg3) of object; + + PParamFlags = ^TParamFlags; + PPPTypeInfo = ^PPTypeInfo; + +var + ti: PTypeInfo; + td: PTypeData; + procparam: PProcedureParam; + pb: PByte; + i: SizeInt; +begin + ti := PTypeInfo(TypeInfo(TTestProc)); + td := GetTypeData(ti); + if td^.ProcSig.ParamCount <> 3 then + Halt(1); + procparam := td^.ProcSig.GetParam(0); + if Assigned(procparam^.ParamType) then + Halt(2); + if procparam^.ParamFlags * [pfVar] <> [pfVar] then + Halt(3); + procparam := td^.ProcSig.GetParam(1); + if Assigned(procparam^.ParamType) then + Halt(4); + if procparam^.ParamFlags * [pfOut] <> [pfOut] then + Halt(5); + procparam := td^.ProcSig.GetParam(2); + if Assigned(procparam^.ParamType) then + Halt(6); + if procparam^.ParamFlags * [pfConstRef] <> [pfConstRef] then + Halt(7); + + ti := PTypeInfo(TypeInfo(TTestMethod)); + td := GetTypeData(ti); + if td^.ParamCount <> 4 then + Halt(8); + pb := @td^.ParamList[0]; + if PParamFlags(pb)^ * [pfHidden, pfSelf] <> [pfHidden, pfSelf] then + Halt(9); + pb := pb + SizeOf(TParamFlags); + pb := pb + SizeOf(Byte) + pb^; + pb := pb + SizeOf(Byte) + pb^; + if PParamFlags(pb)^ * [pfVar] <> [pfVar] then + Halt(10); + pb := pb + SizeOf(TParamFlags); + pb := pb + SizeOf(Byte) + pb^; + pb := pb + SizeOf(Byte) + pb^; + if PParamFlags(pb)^ * [pfOut] <> [pfOut] then + Halt(11); + pb := pb + SizeOf(TParamFlags); + pb := pb + SizeOf(Byte) + pb^; + pb := pb + SizeOf(Byte) + pb^; + if PParamFlags(pb)^ * [pfConstRef] <> [pfConstRef] then + Halt(12); + pb := pb + SizeOf(TParamFlags); + pb := pb + SizeOf(Byte) + pb^; + pb := pb + SizeOf(Byte) + pb^; + + pb := pb + SizeOf(TCallConv); + for i := 1 to td^.ParamCount - 1 do begin + if PPPTypeInfo(pb)[i] <> Nil then begin + Writeln(PPPTypeInfo(pb)[i]^^.Name); + Halt(12 + i); + end; + end; + + Writeln('ok'); +end. diff --git a/tests/webtbf/tw27378.pp b/tests/webtbf/tw27378.pp new file mode 100644 index 0000000000..c03f8744c0 --- /dev/null +++ b/tests/webtbf/tw27378.pp @@ -0,0 +1,14 @@ +{ %FAIL } +{ %OPT=-B -Sen } + +{ we want the "Local variable "Var2" not used" hint as an error; if we don't + get the error then resetting the verbosity when switching the unit failed } + +program tw27378; + +uses + uw27378a, uw27378b; + +begin + +end. diff --git a/tests/webtbf/tw34691.pp b/tests/webtbf/tw34691.pp index f2f28aa3c8..eab3898e92 100644 --- a/tests/webtbf/tw34691.pp +++ b/tests/webtbf/tw34691.pp @@ -10,11 +10,12 @@ uses Classes, SysUtils; type + {$M+} TObjA = class + public Icon: String; end; - {$M+} TObjB = class FObjA: TObjA; diff --git a/tests/webtbf/uw27378a.pp b/tests/webtbf/uw27378a.pp new file mode 100644 index 0000000000..4f51369ae6 --- /dev/null +++ b/tests/webtbf/uw27378a.pp @@ -0,0 +1,13 @@ +unit uw27378a; + +interface + +{$NOTES OFF} + +implementation + +var + Var1: Boolean; + +end. + diff --git a/tests/webtbf/uw27378b.pp b/tests/webtbf/uw27378b.pp new file mode 100644 index 0000000000..24ec13bc6e --- /dev/null +++ b/tests/webtbf/uw27378b.pp @@ -0,0 +1,11 @@ +unit uw27378b; + +interface + +implementation + +var + Var2: Boolean; + +end. + diff --git a/tests/webtbs/tw30205.pp b/tests/webtbs/tw30205.pp new file mode 100644 index 0000000000..c19202f6d7 --- /dev/null +++ b/tests/webtbs/tw30205.pp @@ -0,0 +1,12 @@ +{ %TARGET=win32 } +program tw30205; +{$calling cdecl} +procedure ietest( var f: ansistring ); +var + x: ansistring; +begin + x :='1234'; + f := x; +end; +begin +end.