From 4648407267e243d389b22786041f91344e9f5964 Mon Sep 17 00:00:00 2001 From: Vadim Lou Date: Tue, 21 Mar 2017 19:09:38 +0200 Subject: [PATCH 1/9] fix_20170321_x64call Fixed x64call cause GPF when exception. Added pure pascal vesion. --- Source/uPSComponent.pas | 100 ++-- Source/uPSDebugger.pas | 5 +- Source/uPSRuntime.pas | 155 ++---- Source/x64.inc | 1053 +++++++++++++++++++++++++++++++-------- 4 files changed, 928 insertions(+), 385 deletions(-) diff --git a/Source/uPSComponent.pas b/Source/uPSComponent.pas index 4ef4a172..69000405 100644 --- a/Source/uPSComponent.pas +++ b/Source/uPSComponent.pas @@ -1,5 +1,7 @@ unit uPSComponent; + {$I PascalScript.inc} + interface uses @@ -18,11 +20,11 @@ interface type TPSScript = class; - + TDelphiCallingConvention = uPSRuntime.TPSCallingConvention; {Alias to @link(ifps3.TPSRuntimeClassImporter)} TPSRuntimeClassImporter = uPSRuntime.TPSRuntimeClassImporter; - + TPSPlugin = class(TComponent) public procedure CompOnUses(CompExec: TPSScript); virtual; @@ -37,17 +39,16 @@ TPSPlugin = class(TComponent) procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); virtual; end; - + TIFPS3Plugin = class(TPSPlugin); - + TPSDllPlugin = class(TPSPlugin) public procedure CompOnUses(CompExec: TPSScript); override; procedure ExecOnUses(CompExec: TPSScript); override; end; - - TIFPS3DllPlugin = class(TPSDllPlugin); + TIFPS3DllPlugin = class(TPSDllPlugin); TPSPluginItem = class(TCollectionItem) private @@ -61,32 +62,27 @@ TPSPluginItem = class(TCollectionItem) property Plugin: TPSPlugin read FPlugin write SetPlugin; end; - TIFPS3CEPluginItem = class(TPSPluginItem); - TPSPlugins = class(TCollection) private FCompExec: TPSScript; protected - function GetOwner: TPersistent; override; public - constructor Create(CE: TPSScript); end; - - TIFPS3CEPlugins = class(TPSPlugins); - + TIFPS3CEPlugins = class(TPSPlugins); + TPSOnGetNotVariant = function (Sender: TPSScript; const Name: tbtstring): Variant of object; TPSOnSetNotVariant = procedure (Sender: TPSScript; const Name: tbtstring; V: Variant) of object; TPSCompOptions = set of (icAllowNoBegin, icAllowUnit, icAllowNoEnd, icBooleanShortCircuit); - + TPSVerifyProc = procedure (Sender: TPSScript; Proc: TPSInternalProcedure; const Decl: tbtstring; var Error: Boolean) of object; - + TPSEvent = procedure (Sender: TPSScript) of object; - + TPSOnCompImportEvent = procedure (Sender: TObject; x: TPSPascalCompiler) of object; TPSOnExecImportEvent = procedure (Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter) of object; @@ -101,7 +97,7 @@ TIFPS3CEPlugins = class(TPSPlugins); Var Continue: Boolean) of Object; // jgv TPSScript = class(TComponent) - private + protected FOnGetNotificationVariant: TPSOnGetNotVariant; FOnSetNotificationVariant: TPSOnSetNotVariant; FCanAdd: Boolean; @@ -232,7 +228,6 @@ TPSScript = class(TComponent) function AddFunction(Ptr: Pointer; const Decl: tbtstring): Boolean; - function AddMethodEx(Slf, Ptr: Pointer; const Decl: tbtstring; CallingConv: TDelphiCallingConvention): Boolean; function AddMethod(Slf, Ptr: Pointer; const Decl: tbtstring): Boolean; @@ -268,9 +263,9 @@ TPSScript = class(TComponent) property OnCompile: TPSEvent read FOnCompile write FOnCompile; property OnExecute: TPSEvent read FOnExecute write FOnExecute; - + property OnAfterExecute: TPSEvent read FOnAfterExecute write FOnAfterExecute; - + property OnCompImport: TPSOnCompImportEvent read FOnCompImport write FOnCompImport; property OnExecImport: TPSOnExecImportEvent read FOnExecImport write FOnExecImport; @@ -300,7 +295,6 @@ TPSScript = class(TComponent) TIFPS3CompExec = class(TPSScript); - TPSBreakPointInfo = class private FLine: Longint; @@ -308,16 +302,15 @@ TPSBreakPointInfo = class FFileName: tbtstring; procedure SetFileName(const Value: tbtstring); public - property FileName: tbtstring read FFileName write SetFileName; property FileNameHash: Longint read FFileNameHash; - + property Line: Longint read FLine write FLine; end; - + TPSOnLineInfo = procedure (Sender: TObject; const FileName: tbtstring; Position, Row, Col: Cardinal) of object; - + TPSScriptDebugger = class(TPSScript) private FOnIdle: TNotifyEvent; @@ -333,16 +326,14 @@ TPSScriptDebugger = class(TPSScript) constructor Create(AOwner: TComponent); override; destructor Destroy; override; - procedure Pause; virtual; procedure Resume; virtual; - procedure StepInto; virtual; procedure StepOver; virtual; - + procedure SetBreakPoint(const Fn: tbtstring; Line: Longint); procedure ClearBreakPoint(const Fn: tbtstring; Line: Longint); @@ -364,9 +355,9 @@ TPSScriptDebugger = class(TPSScript) property OnBreakpoint: TPSOnLineInfo read FOnBreakpoint write FOnBreakpoint; end; - + TIFPS3DebugCompExec = class(TPSScriptDebugger); - + TPSCustomPlugin = class(TPSPlugin) private FOnCompileImport2: TPSEvent; @@ -381,17 +372,19 @@ TPSCustomPlugin = class(TPSPlugin) procedure CompileImport1(CompExec: TPSScript); override; procedure CompileImport2(CompExec: TPSScript); override; procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; - procedure ExecImport2(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override; public published property OnCompOnUses : TPSEvent read FOnCompOnUses write FOnCompOnUses; property OnExecOnUses: TPSEvent read FOnExecOnUses write FOnExecOnUses; - property OnCompileImport1: TPSEvent read FOnCompileImport1 write FOnCompileImport1; + property OnCompileImport1: TPSEvent read FOnCompileImport1 write FOnCompileImport1; property OnCompileImport2: TPSEvent read FOnCompileImport2 write FOnCompileImport2; property OnExecImport1: TPSOnExecImportEvent read FOnExecImport1 write FOnExecImport1; property OnExecImport2: TPSOnExecImportEvent read FOnExecImport2 write FOnExecImport2; - end; + end; + +var + PSDebugExecClass: TPSDebugExecClass = TPSDebugExec; // for customize default class TPSDebugExec implementation @@ -439,7 +432,6 @@ function CompExportCheck(Sender: TPSPascalCompiler; Proc: TPSInternalProcedure; Result := TPSScript(Sender.ID).DoVerifyProc (Sender.ID, Proc, ProcDecl); end; - procedure callObjectOnProcessDirective ( Sender: TPSPreProcessor; Parser: TPSPascalPreProcessorParser; @@ -460,7 +452,6 @@ procedure callObjectOnProcessUnknowDirective ( TPSScript (Sender.ID).DoOnProcessUnknowDirective(Sender, Parser, Active, DirectiveName, DirectiveParam, Continue); end; - { TPSPlugin } procedure TPSPlugin.CompileImport1(CompExec: TPSScript); begin @@ -492,7 +483,6 @@ procedure TPSPlugin.ExecOnUses(CompExec: TPSScript); // do nothing end; - { TPSScript } function TPSScript.AddFunction(Ptr: Pointer; @@ -570,7 +560,7 @@ function TPSScript.Compile: Boolean; end; DoOnExecImport (RI); - + for i := 0 to FPlugins.Count -1 do begin if (TPSPluginItem(FPlugins.Items[i]) <> nil)and (TPSPluginItem(FPlugins.Items[i]).Plugin <> nil) then @@ -631,7 +621,10 @@ constructor TPSScript.Create(AOwner: TComponent); begin inherited Create(AOwner); FComp := TPSPascalCompiler.Create; - FExec := TPSDebugExec.Create; + //FExec := TPSDebugExec.Create; + if PSDebugExecClass = nil then PSDebugExecClass := TPSDebugExec; + FExec := PSDebugExecClass.Create; + FScript := TStringList.Create; FPlugins := TPSPlugins.Create(self); @@ -654,21 +647,23 @@ constructor TPSScript.Create(AOwner: TComponent); destructor TPSScript.Destroy; begin - FDefines.Free; + FDefines.Free; FDefines := nil; + + FPP.Free; FPP := nil; + RI.Free; RI := nil; + FPlugins.Free; FPlugins := nil; + FScript.Free; FScript := nil; - FPP.Free; - RI.Free; - FPlugins.Free; - FPlugins := nil; - FScript.Free; - FExec.Free; - FComp.Free; + FExec.Free; FExec := nil; + + FComp.Free; FComp := nil; inherited Destroy; end; function TPSScript.Execute: Boolean; begin - if Running then raise Exception.Create(RPS_ScripEngineAlreadyRunning); + if Running then raise + Exception.Create(RPS_ScripEngineAlreadyRunning); if SuppressLoadData then LoadExec; @@ -846,7 +841,6 @@ procedure TPSScript.SetScript(const Value: TStrings); FScript.Assign(Value); end; - function TPSScript.AddMethod(Slf, Ptr: Pointer; const Decl: tbtstring): Boolean; begin @@ -902,7 +896,6 @@ function TPSScript.TranslatePositionRC(Proc, Position: Cardinal; Result := Exec.TranslatePositionEx(Proc, Position, d1, Row, Col, fn); end; - function TPSScript.GetExecErrorRow: Cardinal; var D1: Cardinal; @@ -945,7 +938,8 @@ procedure TPSScript.SetPointerToData(const VarName: tbtstring; t: TPSVariantIFC; begin v := GetVariable(VarName); - if (Atype = nil) or (v = nil) then raise Exception.Create(RPS_UnableToFindVariable); + if (Atype = nil) or (v = nil) then + raise Exception.Create(RPS_UnableToFindVariable); t.Dta := @PPSVariantData(v).Data; t.aType := v.FType; t.VarParam := false; @@ -1154,8 +1148,6 @@ procedure TPSDllPlugin.ExecOnUses; RegisterDLLRuntime(CompExec.Exec); end; - - { TPS3DebugCompExec } procedure LineInfo(Sender: TPSDebugExec; const FileName: tbtstring; Position, Row, Col: Cardinal); @@ -1393,7 +1385,7 @@ procedure TPSScriptDebugger.SetMainFileName(const Value: tbtstring); end; end; -procedure TPSScriptDebugger.StepInto; +procedure TPSScriptDebugger.StepInto; begin if (FExec.Status = isRunning) or (FExec.Status = isLoaded) then FExec.StepInto @@ -1409,8 +1401,6 @@ procedure TPSScriptDebugger.StepOver; raise Exception.Create(RPS_NoScript); end; - - { TPSPluginItem } procedure TPSPluginItem.Assign(Source: TPersistent); //Birb diff --git a/Source/uPSDebugger.pas b/Source/uPSDebugger.pas index 3b583938..0636b7f3 100644 --- a/Source/uPSDebugger.pas +++ b/Source/uPSDebugger.pas @@ -1,4 +1,3 @@ - unit uPSDebugger; {$I PascalScript.inc} interface @@ -62,6 +61,7 @@ TPSCustomDebugExec = class(TPSExec) destructor Destroy; override; end; TPSDebugExec = class; + TPSDebugExecClass = class of TPSDebugExec; TOnSourceLine = procedure (Sender: TPSDebugExec; const Name: tbtstring; Position, Row, Col: Cardinal); @@ -137,7 +137,8 @@ implementation procedure TPSCustomDebugExec.Clear; begin inherited Clear; - if FGlobalVarNames <> nil then ClearDebug; + if FGlobalVarNames <> nil then + ClearDebug; end; procedure TPSCustomDebugExec.ClearDebug; diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index f59f77c4..f23665b9 100644 --- a/Source/uPSRuntime.pas +++ b/Source/uPSRuntime.pas @@ -1,5 +1,4 @@ unit uPSRuntime; -{$I PascalScript.inc} { RemObjects Pascal Script III @@ -7,11 +6,13 @@ } +{$I PascalScript.inc} + interface + uses SysUtils, uPSUtils{$IFDEF DELPHI6UP}, variants{$ENDIF}{$IFDEF MACOS},uPSCMac{$ELSE}{$IFNDEF PS_NOIDISPATCH}{$IFDEF DELPHI3UP}, ActiveX, Windows{$ELSE}, Ole2{$ENDIF}{$ENDIF}{$ENDIF}; - type TPSExec = class; TPSStack = class; @@ -52,12 +53,10 @@ TPSProcRec = class private FAttributes: TPSRuntimeAttributes; public - constructor Create(Owner: TPSExec); destructor Destroy; override; - property Attributes: TPSRuntimeAttributes read FAttributes; end; @@ -135,7 +134,6 @@ TPSTypeRec = class protected FRealSize: Cardinal; public - property RealSize: Cardinal read FRealSize; property BaseType: TPSBaseType read FBaseType write FBaseType; @@ -156,7 +154,6 @@ TPSTypeRec_ProcPtr = class(TPSTypeRec) private FParamInfo: tbtstring; public - property ParamInfo: tbtstring read FParamInfo write FParamInfo; procedure CalcSize; override; end; @@ -166,7 +163,6 @@ TPSTypeRec_Class = class(TPSTypeRec) private FCN: tbtstring; public - property CN: tbtstring read FCN write FCN; end; {$IFNDEF PS_NOINTERFACES} @@ -175,7 +171,6 @@ TPSTypeRec_Interface = class(TPSTypeRec) private FGuid: TGUID; public - property Guid: TGUID read FGuid write FGuid; end; {$ENDIF} @@ -184,7 +179,6 @@ TPSTypeRec_Array = class(TPSTypeRec) private FArrayType: TPSTypeRec; public - property ArrayType: TPSTypeRec read FArrayType write FArrayType; procedure CalcSize; override; end; @@ -194,7 +188,6 @@ TPSTypeRec_StaticArray = class(TPSTypeRec_Array) FSize: Longint; FStartOffset: LongInt; public - property Size: Longint read FSize write FSize; property StartOffset: LongInt read FStartOffset write FStartOffset; @@ -217,9 +210,7 @@ TPSTypeRec_Record = class(TPSTypeRec) FFieldTypes: TPSList; FRealFieldOffsets: TPSList; public - property FieldTypes: TPSList read FFieldTypes; - property RealFieldOffsets: TPSList read FRealFieldOffsets; procedure CalcSize; override; @@ -250,7 +241,6 @@ TPSTypeRec_Record = class(TPSTypeRec) Data: tbtU8; end; - PPSVariantS8 = ^TPSVariantS8; TPSVariantS8 = packed record @@ -258,7 +248,6 @@ TPSTypeRec_Record = class(TPSTypeRec) Data: tbts8; end; - PPSVariantU16 = ^TPSVariantU16; TPSVariantU16 = packed record @@ -266,7 +255,6 @@ TPSTypeRec_Record = class(TPSTypeRec) Data: tbtU16; end; - PPSVariantS16 = ^TPSVariantS16; TPSVariantS16 = packed record @@ -274,7 +262,6 @@ TPSTypeRec_Record = class(TPSTypeRec) Data: tbts16; end; - PPSVariantU32 = ^TPSVariantU32; TPSVariantU32 = packed record @@ -282,7 +269,6 @@ TPSTypeRec_Record = class(TPSTypeRec) Data: tbtU32; end; - PPSVariantS32 = ^TPSVariantS32; TPSVariantS32 = packed record @@ -341,7 +327,6 @@ TPSTypeRec_Record = class(TPSTypeRec) {$ENDIF} - PPSVariantSingle = ^TPSVariantSingle; TPSVariantSingle = packed record @@ -349,7 +334,6 @@ TPSTypeRec_Record = class(TPSTypeRec) Data: tbtsingle; end; - PPSVariantDouble = ^TPSVariantDouble; TPSVariantDouble = packed record @@ -357,7 +341,6 @@ TPSTypeRec_Record = class(TPSTypeRec) Data: tbtDouble; end; - PPSVariantExtended = ^TPSVariantExtended; TPSVariantExtended = packed record @@ -365,7 +348,6 @@ TPSTypeRec_Record = class(TPSTypeRec) Data: tbtExtended; end; - PPSVariantCurrency = ^TPSVariantCurrency; TPSVariantCurrency = packed record @@ -397,7 +379,6 @@ TPSTypeRec_Record = class(TPSTypeRec) Data: TObject; end; - PPSVariantRecord = ^TPSVariantRecord; TPSVariantRecord = packed record @@ -405,7 +386,6 @@ TPSTypeRec_Record = class(TPSTypeRec) data: array[0..0] of byte; end; - PPSVariantDynamicArray = ^TPSVariantDynamicArray; TPSVariantDynamicArray = packed record @@ -413,7 +393,6 @@ TPSTypeRec_Record = class(TPSTypeRec) Data: Pointer; end; - PPSVariantStaticArray = ^TPSVariantStaticArray; TPSVariantStaticArray = packed record @@ -421,7 +400,6 @@ TPSTypeRec_Record = class(TPSTypeRec) data: array[0..0] of byte; end; - PPSVariantPointer = ^TPSVariantPointer; TPSVariantPointer = packed record @@ -431,7 +409,6 @@ TPSTypeRec_Record = class(TPSTypeRec) FreeIt: LongBool; end; - PPSVariantReturnAddress = ^TPSVariantReturnAddress; TPSVariantReturnAddress = packed record @@ -439,7 +416,6 @@ TPSTypeRec_Record = class(TPSTypeRec) Addr: TBTReturnAddress; end; - PPSVariantVariant = ^TPSVariantVariant; TPSVariantVariant = packed record @@ -458,7 +434,6 @@ TPSTypeRec_Record = class(TPSTypeRec) } end; - TPSVarFreeType = ( vtNone, vtTempVar @@ -470,7 +445,6 @@ TPSTypeRec_Record = class(TPSTypeRec) FreeType: TPSVarFreeType; end; - PPSResource = ^TPSResource; TPSResource = record @@ -513,7 +487,6 @@ TClassItem = record 7: (); {Property helper that will pass it's name} end; - PPSVariantIFC = ^TPSVariantIFC; {Temporary variant into record} TPSVariantIFC = packed record @@ -533,7 +506,6 @@ TPSRuntimeAttribute = class(TObject) function GetValue(I: Longint): PIFVariant; function GetValueCount: Longint; public - property Owner: TPSRuntimeAttributes read FOwner; property AttribType: tbtstring read FAttribType write FAttribType; @@ -547,10 +519,8 @@ TPSRuntimeAttribute = class(TObject) function AddValue(aType: TPSTypeRec): PPSVariant; procedure DeleteValue(i: Longint); - procedure AdjustSize; - constructor Create(Owner: TPSRuntimeAttributes); destructor Destroy; override; @@ -563,7 +533,6 @@ TPSRuntimeAttributes = class(TObject) function GetCount: Longint; function GetItem(I: Longint): TPSRuntimeAttribute; public - property Owner: TPSExec read FOwner; property Count: Longint read GetCount; @@ -576,7 +545,6 @@ TPSRuntimeAttributes = class(TObject) function FindAttribute(const Name: tbtstring): TPSRuntimeAttribute; - constructor Create(AOwner: TPSExec); destructor Destroy; override; @@ -609,9 +577,7 @@ TPSExec = class(TObject) function DoIntegerNot(Dta: Pointer; aType: TPSTypeRec): Boolean; procedure RegisterStandardProcs; Protected - FReturnAddressType: TPSTypeRec; - FVariantType: TPSTypeRec; FVariantArrayType: TPSTypeRec; @@ -625,7 +591,6 @@ TPSExec = class(TObject) FExportedVars: TPSList; FTypes: TPSList; - FProcs: TPSList; FGlobalVars: TPSStack; @@ -639,7 +604,6 @@ TPSExec = class(TObject) FStatus: TPSStatus; FCurrProc: TPSInternalProcRec; - FData: PByteArray; FDataLength: Cardinal; @@ -653,7 +617,6 @@ TPSExec = class(TObject) FSpecialProcList: TPSList; FRegProcs: TPSList; - ExObject: TObject; ExProc: Cardinal; @@ -722,12 +685,9 @@ TPSExec = class(TObject) function GetTypeCount: Longint; - constructor Create; - destructor Destroy; Override; - function RunScript: Boolean; @@ -809,7 +769,6 @@ TPSStack = class(TPSList) property Length: Longint read FLength; - constructor Create; destructor Destroy; override; @@ -856,7 +815,6 @@ TPSStack = class(TPSList) property Items[I: Longint]: PPSVariant read GetItem; default; end; - function PSErrorToString(x: TPSError; const Param: tbtstring): tbtstring; function TIFErrorToString(x: TPSError; const Param: tbtstring): tbtstring; function CreateHeapVariant(aType: TPSTypeRec): PPSVariant; @@ -868,7 +826,6 @@ procedure FreePSVariantList(l: TPSList); const ENoError = ERNoError; - function PIFVariantToVariant(Src: PIFVariant; var Dest: Variant): Boolean; function VariantToPIFVariant(Exec: TPSExec; const Src: Variant; Dest: PIFVariant): Boolean; @@ -884,7 +841,6 @@ procedure DisposePPSVariantIFC(aVar: PPSVariantIFC); procedure DisposePPSVariantIFCList(list: TPSList); - function PSGetObject(Src: Pointer; aType: TPSTypeRec): TObject; function PSGetUInt(Src: Pointer; aType: TPSTypeRec): Cardinal; {$IFNDEF PS_NOINT64} @@ -1046,7 +1002,6 @@ TPSRuntimeClassImporter = class TIFPSRuntimeClassImporter = TPSRuntimeClassImporter; TPSResourceFreeProc = procedure (Sender: TPSExec; P: TPSRuntimeClassImporter); - procedure RegisterClassLibraryRuntime(SE: TPSExec; Importer: TPSRuntimeClassImporter); procedure SetVariantToClass(V: PIFVariant; Cl: TObject); @@ -1068,7 +1023,6 @@ function MkMethod(FSE: TPSExec; No: Cardinal): TMethod; TIFPSStack = TPSStack; TIFTypeRec = TPSTypeRec; - TPSCallingConvention = uPSUtils.TPSCallingConvention; const @@ -1098,6 +1052,20 @@ function MakeWString(const s: tbtunicodestring): tbtstring; function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: array of Variant): Variant; {$ENDIF} +type + TPSExceptionHandler = class // Moved from implementation section and added access to ExceptionObject. + protected + CurrProc: TPSInternalProcRec; + BasePtr, StackSize: Cardinal; + FinallyOffset, ExceptOffset, Finally2Offset, EndOfBlock: Cardinal; + ExceptionData: TPSError; + ExceptionObject: TObject; + ExceptionParam: tbtString; + public + destructor Destroy; override; + + property CurrentExceptionObject: TObject read ExceptionObject; + end;//} implementation uses @@ -1139,7 +1107,6 @@ implementation RPS_InterfaceNotSupported = 'Interface not supported'; RPS_UnknownError = 'Unknown error'; - RPS_InvalidVariable = 'Invalid variable'; RPS_InvalidArray = 'Invalid array'; RPS_OLEError = 'OLE error %.8x'; @@ -1155,8 +1122,6 @@ implementation RPS_NILInterfaceException = 'Nil interface'; RPS_UnknownMethod = 'Unknown method'; - - type PPSExportedVar = ^TPSExportedVar; TPSExportedVar = record @@ -1171,7 +1136,7 @@ TRaiseFrame = record ExceptObject: TObject; ExceptionRecord: Pointer; end; - TPSExceptionHandler = class + {TPSExceptionHandler = class // Moved to interface section CurrProc: TPSInternalProcRec; BasePtr, StackSize: Cardinal; FinallyOffset, ExceptOffset, Finally2Offset, EndOfBlock: Cardinal; @@ -1179,7 +1144,7 @@ TPSExceptionHandler = class ExceptionObject: TObject; ExceptionParam: tbtString; destructor Destroy; override; - end; + end;//} TPSHeader = packed record HDR: Cardinal; PSBuildNo: Cardinal; @@ -1249,7 +1214,6 @@ procedure P_CM_DEC; begin end; function IntPIFVariantToVariant(Src: pointer; aType: TPSTypeRec; var Dest: Variant): Boolean; forward; - procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer); var i: Longint; @@ -1309,7 +1273,6 @@ procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean); Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0; end; - procedure RCIFreeProc(Sender: TPSExec; P: TPSRuntimeClassImporter); begin p.Free; @@ -1380,8 +1343,8 @@ function uPadr(s: tbtunicodestring; i: longInt): tbtunicodestring; begin result := s + StringOfChar(tbtwidechar(' '), i - Length(s)); end; - {$ENDIF} + {$IFNDEF PS_NOWIDESTRING} function MakeWString(const s: tbtunicodestring): tbtString; var @@ -1434,6 +1397,7 @@ function MakeWString(const s: tbtunicodestring): tbtString; Result := ''''''; end; {$ENDIF} + function MakeString(const s: tbtString): tbtString; var i: Longint; @@ -1498,7 +1462,6 @@ function SafeStr(const s: tbtString): tbtString; exit; end; end; - end; function PropertyToString(Instance: TObject; PName: tbtString): tbtString; @@ -1658,8 +1621,6 @@ function PSVariantToString(const p: TPSVariantIFC; const ClassProperties: tbtStr end; end; - - function TIFErrorToString(x: TPSError; const Param: tbtString): tbtString; begin Result := PSErrorToString(x,param); @@ -1699,7 +1660,6 @@ function PSErrorToString(x: TPSError; const Param: tbtString): tbtString; // end; - procedure TPSTypeRec.CalcSize; begin case BaseType of @@ -1757,7 +1717,6 @@ destructor TPSTypeRec_Record.Destroy; inherited Destroy; end; - const RTTISize = sizeof(TPSVariant); @@ -3244,7 +3203,6 @@ function VGetUnicodeString(const Src: PIFVariant): tbtunicodestring; {$ENDIF} - procedure VSetPointerTo(const Src: PIFVariant; Data: Pointer; aType: TPSTypeRec); var temp: TPSVariantIFC; @@ -3328,7 +3286,6 @@ procedure VSetString(const Src: PIFVariant; const Val: string); {$ENDIF} end; - {$IFNDEF PS_NOWIDESTRING} procedure VSetWideString(const Src: PIFVariant; const Val: tbtWideString); var @@ -3344,7 +3301,6 @@ procedure VSetUnicodeString(const Src: PIFVariant; const Val: tbtunicodestring); PSSetUnicodeString(@PPSVariantData(src).Data, src.FType, Dummy, Val); end; - {$ENDIF} {$IFNDEF PS_NOWIDESTRING} @@ -3425,7 +3381,6 @@ procedure PSSetObject(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; Const va end; end; - {$IFNDEF PS_NOINT64} function PSGetInt64(Src: Pointer; aType: TPSTypeRec): Int64; begin @@ -3505,7 +3460,6 @@ function PSGetCurrency(Src: Pointer; aType: TPSTypeRec): Currency; end; end; - function PSGetInt(Src: Pointer; aType: TPSTypeRec): Longint; begin if aType.BaseType = btPointer then @@ -3529,7 +3483,6 @@ function PSGetInt(Src: Pointer; aType: TPSTypeRec): Longint; end; end; - function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString; begin if aType.BaseType = btPointer then @@ -3551,6 +3504,7 @@ function PSGetAnsiString(Src: Pointer; aType: TPSTypeRec): tbtString; else raise Exception.Create(RPS_TypeMismatch); end; end; + {$IFNDEF PS_NOWIDESTRING} function PSGetWideString(Src: Pointer; aType: TPSTypeRec): tbtWideString; begin @@ -3772,7 +3726,6 @@ procedure PSSetInt(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: end; end; - procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtString); begin if (Src = nil) or (aType = nil) then begin Ok := false; exit; end; @@ -3785,7 +3738,7 @@ procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; cons case aType.BaseType of btString: tbtstring(src^) := val; btChar: if AnsiString(val) <> '' then tbtchar(src^) := AnsiString(val)[1]; -{$IFNDEF PS_NOWIDESTRING} + {$IFNDEF PS_NOWIDESTRING} btUnicodeString: tbtunicodestring(src^) := tbtUnicodeString(AnsiString(val)); btWideString: tbtwidestring(src^) := tbtwidestring(AnsiString(val)); btWideChar: if AnsiString(val) <> '' then tbtwidechar(src^) := tbtwidechar(AnsiString(val)[1]); @@ -3801,6 +3754,7 @@ procedure PSSetAnsiString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; cons else ok := false; end; end; + {$IFNDEF PS_NOWIDESTRING} procedure PSSetWideString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Val: tbtWideString); begin @@ -3881,7 +3835,6 @@ procedure PSSetString(Src: Pointer; aType: TPSTypeRec; var Ok: Boolean; const Va {$ENDIF} end; - function CopyArrayContents(dest, src: Pointer; Len: Longint; aType: TPSTypeRec): Boolean; forward; function CopyRecordContents(dest, src: Pointer; aType: TPSTypeRec_Record): Boolean; @@ -4173,7 +4126,6 @@ procedure SetPSArrayLength(Arr: PIFVariant; NewLength: Longint); PSDynArraySetLength(PPSVariantDynamicArray(arr).Data, arr.FType, NewLength); end; - function PSDynArrayGetLength(arr: Pointer; aType: TPSTypeRec): Longint; begin if aType.BaseType <> btArray then raise Exception.Create(RPS_InvalidArray); @@ -4251,7 +4203,6 @@ procedure PSDynArraySetLength(var arr: Pointer; aType: TPSTypeRec; NewLength: Lo end; end; - {$IFDEF FPC} {$DEFINE FPC_OR_KYLIX} {$ENDIF} @@ -4278,7 +4229,6 @@ procedure OleCheck(Result: HResult); end; {$ENDIF} - {$IFNDEF DELPHI3UP} function OleErrorMessage(ErrorCode: HResult): tbtString; begin @@ -4671,7 +4621,6 @@ function TPSExec.SetVariantValue(dest, Src: Pointer; desttype, srctype: TPSTypeR function SpecImport(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; forward; - function Class_IS(Self: TPSExec; Obj: TObject; var2type: TPSTypeRec): Boolean; var R: TPSRuntimeClassImporter; @@ -4719,14 +4668,12 @@ function VariantInArray(var1: Pointer; var1Type: TPSTypeRec; var2: PVariantArray end; end; - function TPSExec.DoBooleanCalc(var1, Var2, into: Pointer; var1Type, var2type, intotype: TPSTypeRec; Cmd: Cardinal): Boolean; var b: Boolean; Tmp: TObject; tvar: Variant; - procedure SetBoolean(b: Boolean; var Ok: Boolean); begin Ok := True; @@ -6384,7 +6331,6 @@ function TPSExec.ReadVariable(var Dest: TPSResultData; UsePointer: Boolean): Boo Param: Cardinal; Tmp: PIfVariant; at: TPSTypeRec; - begin if FCurrentPosition + 4 >= FDataLength then begin @@ -7028,7 +6974,6 @@ function TPSExec.DoBooleanNot(Dta: Pointer; aType: TPSTypeRec): Boolean; Result := True; end; - procedure TPSExec.Stop; begin if FStatus = isRunning then @@ -7040,7 +6985,6 @@ procedure TPSExec.Stop; end; end; - function TPSExec.ReadLong(var b: Cardinal): Boolean; begin if FCurrentPosition + 3 < FDataLength then begin @@ -7105,6 +7049,7 @@ function TPSExec.RunProcP(const Params: array of Variant; const Procno: Cardinal FreePIFVariantList(ParamList); end; end; + function TPSExec.RunProcPVar(var Params: array of Variant; const Procno: Cardinal): Variant; var ParamList: TPSList; @@ -7169,7 +7114,6 @@ function TPSExec.RunProcPN(const Params: array of Variant; const ProcName: tbtSt Result := RunProcP(Params, ProcNo); end; - function TPSExec.RunProc(Params: TPSList; ProcNo: Cardinal): Boolean; var I, I2: Integer; @@ -7309,7 +7253,6 @@ function TPSExec.RunProc(Params: TPSList; ProcNo: Cardinal): Boolean; end; end; - function TPSExec.FindType2(BaseType: TPSBaseType): PIFTypeRec; var l: Cardinal; @@ -7381,7 +7324,6 @@ function TPSExec.GetType(const Name: tbtString): Cardinal; Result := InvalidVal; end; - procedure TPSExec.AddResource(Proc, P: Pointer); var Temp: PPSResource; @@ -8827,7 +8769,7 @@ function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack 8: // StrSet begin temp := NewTPSVariantIFC(Stack[Stack.Count -3], True); - if (temp.Dta = nil) or not (temp.aType.BaseType in [btString, btUnicodeString]) then + if (temp.Dta = nil) or not (temp.aType.BaseType in [btString, btUnicodeString]) then begin Result := False; exit; @@ -8874,7 +8816,7 @@ function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack else if Stack.GetItem(Stack.Count -2)^.FType.BaseType = btWideString then Stack.SetWideString(-1, SysUtils.Trim(Stack.GetWideString(-2))) // Trim else -{$ENDIF} +{$ENDIF} Stack.SetAnsiString(-1, AnsiString(SysUtils.Trim(String(Stack.GetAnsiString(-2)))));// Trim 13: Stack.SetInt(-1, Length(Stack.GetAnsiString(-2))); // Length 14: // SetLength @@ -9071,6 +9013,7 @@ function DefProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack end; Result := True; end; + function GetArrayLength(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; var arr: TPSVariantIFC; @@ -9102,7 +9045,6 @@ function SetArrayLength(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: T Result := True; end; - function InterfaceProc(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; forward; procedure RegisterInterfaceLibraryRuntime(Se: TPSExec); @@ -9172,7 +9114,6 @@ function Length_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack end; end; - function SetLength_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; var arr: TPSVariantIFC; @@ -9319,7 +9260,6 @@ function Exclude_(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStac SetData^[Val shr 3] := SetData^[Val shr 3] and not (1 shl (Val and 7)); end; - {$IFNDEF DELPHI6UP} function _VarArrayGet(var S : Variant; I : Integer) : Variant; begin @@ -9394,7 +9334,6 @@ procedure TPSExec.RegisterStandardProcs; RegisterDelphiFunction(@IDispatchInvoke, 'IdispatchInvoke', cdregister); {$ENDIF} - RegisterFunctionName('GetArrayLength', GetArrayLength, nil, nil); RegisterFunctionName('SetArrayLength', SetArrayLength, nil, nil); @@ -9427,7 +9366,6 @@ procedure TPSExec.RegisterStandardProcs; RegisterInterfaceLibraryRuntime(Self); end; - function ToString(p: PansiChar): tbtString; begin SetString(Result, p, StrLen(p)); @@ -9812,7 +9750,6 @@ procedure DestroyOpenArray(Sender: TPSExec; V: POpenArray); Dispose(V); end; - {$ifndef FPC} {$IFDEF Delphi6UP} {$IFDEF CPUX64} @@ -9848,7 +9785,6 @@ TScriptMethodInfo = record ProcNo: Cardinal; end; - function MkMethod(FSE: TPSExec; No: Cardinal): TMethod; begin if (no = 0) or (no = InvalidVal) then @@ -9861,7 +9797,6 @@ function MkMethod(FSE: TPSExec; No: Cardinal): TMethod; end; end; - procedure PFree(Sender: TPSExec; P: PScriptMethodInfo); begin Dispose(p); @@ -9893,10 +9828,6 @@ function GetMethodInfoRec(SE: TPSExec; ProcNo: Cardinal): Pointer; Result := pp; end; - - - - type TPtrArr = array[0..1000] of Pointer; PPtrArr = ^TPtrArr; @@ -9904,7 +9835,6 @@ function GetMethodInfoRec(SE: TPSExec; ProcNo: Cardinal): Pointer; PByteArr = ^TByteArr; PPointer = ^Pointer; - function VirtualMethodPtrToPtr(Ptr, FSelf: Pointer): Pointer; {$IFDEF FPC} var @@ -9933,7 +9863,6 @@ function VirtualClassMethodPtrToPtr(Ptr, FSelf: Pointer): Pointer; {$ENDIF} end; - procedure CheckPackagePtr(var P: PByteArr); begin {$ifdef Win32} @@ -10030,7 +9959,6 @@ function FindVirtualMethodPtr(Ret: TPSRuntimeClass; FClass: TClass; Ptr: Pointer {$ENDIF} - function NewTPSVariantIFC(avar: PPSVariant; varparam: boolean): TPSVariantIFC; begin Result.VarParam := varparam; @@ -10122,7 +10050,6 @@ function NewPPSVariantIFC(avar: PPSVariant; varparam: boolean): PPSVariantIFC; Result^ := NewTPSVariantIFC(avar, varparam); end; - procedure DisposePPSVariantIFC(aVar: PPSVariantIFC); begin if avar <> nil then @@ -10298,7 +10225,6 @@ function ClassCallProcConstructor(Caller: TPSExec; p: TPSExternalProcRec; Global end; end; - function ClassCallProcVirtualConstructor(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; var i, h: Longint; @@ -10468,7 +10394,6 @@ function CastProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStac result := True; end; - function NilProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; var n: TPSVariantIFC; @@ -10493,6 +10418,7 @@ function NilProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack Pointer(n.Dta^) := nil; result := True; end; + function IntfCallProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; var i: Integer; @@ -10548,7 +10474,6 @@ function IntfCallProc(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPS end; end; - function InterfaceProc(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Boolean; var s: tbtString; @@ -10576,7 +10501,6 @@ function InterfaceProc(Sender: TPSExec; p: TPSExternalProcRec; Tag: Pointer): Bo end else Result := False; end; - function getMethodNo(P: TMethod; SE: TPSExec): Cardinal; begin if (p.Code <> @MyAllMethodsHandler) or (p.Data = nil)or (PScriptMethodInfo(p.Data)^.Se <> se) then @@ -10865,8 +10789,6 @@ function ClassCallProcPropertyHelperName(Caller: TPSExec; p: TPSExternalProcRec; end; end; - - function ClassCallProcEventPropertyHelper(Caller: TPSExec; p: TPSExternalProcRec; Global, Stack: TPSStack): Boolean; {Event property helper} var @@ -10977,7 +10899,6 @@ function ClassCallProcEventPropertyHelper(Caller: TPSExec; p: TPSExternalProcRec end; end; - {'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params For property write functions there is an '@' after the funcname. @@ -11151,7 +11072,6 @@ procedure RegisterClassLibraryRuntime(SE: TPSExec; Importer: TPSRuntimeClassImpo SE.AddSpecialProcImport('class', SpecImport, Importer); end; - procedure TPSExec.ClearspecialProcImports; var I: Longint; @@ -11203,7 +11123,6 @@ function TPSExec.GetProcAsMethodN(const ProcName: tbtString): TMethod; Result := MkMethod(Self, procno) end; - procedure TPSExec.RegisterAttributeType(useproc: TPSAttributeUseProc; const TypeName: tbtString); var @@ -11316,7 +11235,6 @@ function TPSExec.LastExPos: Integer; end; pp := fExceptionStack[fExceptionStack.Count-1]; result := pp.ExceptOffset; - end; function TPSExec.LastExProc: Integer; @@ -11341,7 +11259,7 @@ function TPSExec.LastExObject: TObject; end; pp := fExceptionStack[fExceptionStack.Count-1]; result := pp.ExceptionObject; -end; +end; { TPSRuntimeClass } @@ -11413,7 +11331,6 @@ procedure TPSRuntimeClass.RegisterMethod(ProcPtr: Pointer; const Name: tbtString FClassItems.Add(p); end; - procedure TPSRuntimeClass.RegisterPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: tbtString); var @@ -11467,7 +11384,6 @@ procedure TPSRuntimeClass.RegisterEventPropertyHelper(ReadFunc, FClassItems.Add(p); end; - procedure TPSRuntimeClass.RegisterPropertyHelperName(ReadFunc, WriteFunc: Pointer; const Name: tbtString); var @@ -11594,7 +11510,6 @@ procedure MyAllMethodsHandler; end; {$else} - function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer; forward; procedure MyAllMethodsHandler; @@ -11691,15 +11606,12 @@ function AlwaysAsVariable(aType: TPSTypeRec): Boolean; end; end; - procedure PutOnFPUStackExtended(ft: extended); asm // fstp tbyte ptr [ft] fld tbyte ptr [ft] - end; - function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer; var Decl: tbtString; @@ -11711,8 +11623,6 @@ function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _E s,e: tbtString; FStack: pointer; ex: TPSExceptionHandler; - - begin Decl := TPSInternalProcRec(Self^.Se.FProcs[Self^.ProcNo]).ExportDecl; @@ -12527,7 +12437,6 @@ procedure TPSStack.SetString(ItemNo: Longint; const Data: string); {$ENDIF} end; - procedure TPSStack.SetUInt(ItemNo: Longint; const Data: Cardinal); var val: PPSVariant; @@ -12542,7 +12451,6 @@ procedure TPSStack.SetUInt(ItemNo: Longint; const Data: Cardinal); if not ok then raise Exception.Create(RPS_TypeMismatch); end; - {$IFNDEF PS_NOWIDESTRING} procedure TPSStack.SetUnicodeString(ItemNo: Integer; const Data: tbtunicodestring); @@ -12574,7 +12482,6 @@ procedure TPSStack.SetWideString(ItemNo: Longint; end; {$ENDIF} - {$IFNDEF PS_NOIDISPATCH} var DispPropertyPut: Integer = DISPID_PROPERTYPUT; @@ -12716,7 +12623,6 @@ function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtS end; {$ENDIF} - { TPSTypeRec_ProcPtr } procedure TPSTypeRec_ProcPtr.CalcSize; @@ -12725,4 +12631,3 @@ procedure TPSTypeRec_ProcPtr.CalcSize; end; end. - diff --git a/Source/x64.inc b/Source/x64.inc index 23a68509..f8cbc3c3 100644 --- a/Source/x64.inc +++ b/Source/x64.inc @@ -1,3 +1,7 @@ +{ x64.inc } + +{.$O-,D+,L+} // for debug + {$IFDEF DELPHI} {$DEFINE PS_RESBEFOREPARAMETERS} {$DEFINE x64_string_result_as_varparameter} @@ -6,14 +10,466 @@ { implementation of x64 abi } //procedure DebugBreak; external 'Kernel32.dll'; const - EmptyPchar: array[0..0] of char = #0; -{$IFDEF FPC} -{$ASMMODE INTEL} -{$ENDIF} + EmptyPChar: array[0..0] of Char = (Char(#0)); + +type + EInvocationError = class(Exception); + +// +// Calculate/Declare defines +// +{$UNDEF X64CALL_ASM} { not change } +{$UNDEF REG_STACK_PTR_OFFSET0} { not change } {$IFDEF MSWINDOWS}{$DEFINE WINDOWS}{$ENDIF} +{$IFDEF MSWINDOWS} + {$IFDEF CPUX64} + + {$IFDEF DELPHI} + {$DEFINE X64CALL_ASM} { optional } // ! Successfully on exceptions ! + {$ENDIF} + + {$IFDEF FPC} + {.$DEFINE X64CALL_ASM} { optional } // ! Not recomended : GPF on exception ! + {$ENDIF} + + {$ELSE} + + {$ENDIF} +{$ELSE !MSWINDOWS} + + {$DEFINE X64CALL_ASM} { optional } // TODO: Check pas version (disable "X64CALL_ASM"). + +{$ENDIF !MSWINDOWS} + +{$IFNDEF X64CALL_ASM} // PURE PASCAL version. ! DELPHI/FPC: Successfully on exceptions ! +type + {$IFDEF CPUX64} + t_pstask = array[0..61] of IPointer; + p_pstask = ^t_pstask; + TRegisters = packed record + _RCX, // 0 + _RDX, // 8 + _R8, // 16 + _R9: IPointer; // 24 + _XMM1, // 32 + _XMM2, // 40 + _XMM3: Double; // 48 + case byte of + 0:( + Stack: Pointer; // 56 + Items: {$IFDEF FPC}PtrUInt{$ELSE}IntPtr{$ENDIF}; // 64 + SingleBits: Integer; // 72 + ); + 1:(S: p_pstask); + end; + {$ENDIF CPUX64} + {$DEFINE REG_STACK_PTR_OFFSET0} { not change } +type + t_pcall_04 = procedure(_rcx,_rdx,_r8,_r9: IPointer); + t_pcall_05 = procedure(_rcx,_rdx,_r8,_r9,p5: IPointer); + t_pcall_06 = procedure(_rcx,_rdx,_r8,_r9,p5,p6: IPointer); + t_pcall_07 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7: IPointer); + t_pcall_08 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8: IPointer); + t_pcall_09 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9: IPointer); + t_pcall_10 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10: IPointer); + t_pcall_11 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11: IPointer); + t_pcall_12 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12: IPointer); + t_pcall_13 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13: IPointer); + t_pcall_14 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14: IPointer); + t_pcall_15 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15: IPointer); + t_pcall_16 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16: IPointer); + t_pcall_17 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17: IPointer); + t_pcall_18 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18: IPointer); + t_pcall_19 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19: IPointer); + t_pcall_20 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20: IPointer); + t_pcall_21 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21: IPointer); + t_pcall_22 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22: IPointer); + t_pcall_23 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23: IPointer); + t_pcall_24 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24: IPointer); + t_pcall_25 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25: IPointer); + t_pcall_26 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26: IPointer); + t_pcall_27 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27: IPointer); + t_pcall_28 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28: IPointer); + t_pcall_29 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29: IPointer); + t_pcall_30 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30: IPointer); + t_pcall_31 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31: IPointer); + t_pcall_32 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32: IPointer); + t_pcall_33 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33: IPointer); + t_pcall_34 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34: IPointer); + t_pcall_35 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35: IPointer); + t_pcall_36 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36: IPointer); + t_pcall_37 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37: IPointer); + t_pcall_38 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38: IPointer); + t_pcall_39 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39: IPointer); + t_pcall_40 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40: IPointer); + t_pcall_41 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41: IPointer); + t_pcall_42 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42: IPointer); + t_pcall_43 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43: IPointer); + t_pcall_44 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44: IPointer); + t_pcall_45 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45: IPointer); + t_pcall_46 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46: IPointer); + t_pcall_47 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47: IPointer); + t_pcall_48 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48: IPointer); + t_pcall_49 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49: IPointer); + t_pcall_50 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50: IPointer); + t_pcall_51 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51: IPointer); + t_pcall_52 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52: IPointer); + t_pcall_53 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53: IPointer); + t_pcall_54 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54: IPointer); + t_pcall_55 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55: IPointer); + t_pcall_56 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56: IPointer); + t_pcall_57 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57: IPointer); + t_pcall_58 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58: IPointer); + t_pcall_59 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59: IPointer); + t_pcall_60 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60: IPointer); + t_pcall_61 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61: IPointer); + t_pcall_62 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62: IPointer); + t_pcall_63 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63: IPointer); + t_pcall_64 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63,p64: IPointer); + t_pcall_65 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63,p64,p65: IPointer); + t_pcall_66 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63,p64,p65,p66: IPointer); +procedure x64call({RCX}Address: Pointer;out {RDX}_RAX: IPointer;var {R8}_XMM0: Double; var {R9}R: TRegisters); +begin + case R.Items of // stack items count + 00: t_pcall_04(Address)(R._RCX,R._RDX,R._R8,R._R9); + 01: t_pcall_05(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00]); + 02: t_pcall_06(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01]); + 03: t_pcall_07(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02]); + 04: t_pcall_08(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03]); + 05: t_pcall_09(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04]); + 06: t_pcall_10(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05]); + 07: t_pcall_11(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06]); + 08: t_pcall_12(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07]); + 09: t_pcall_13(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08]); + 10: t_pcall_14(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09]); + 11: t_pcall_15(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10]); + 12: t_pcall_16(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11]); + 13: t_pcall_17(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12]); + 14: t_pcall_18(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13]); + 15: t_pcall_19(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14]); + 16: t_pcall_20(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15]); + 17: t_pcall_21(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16]); + 18: t_pcall_22(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17]); + 19: t_pcall_23(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18]); + 20: t_pcall_24(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19]); + 21: t_pcall_25(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20]); + 22: t_pcall_26(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21]); + 23: t_pcall_27(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22]); + 24: t_pcall_28(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23]); + 25: t_pcall_29(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24]); + 26: t_pcall_30(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25]); + 27: t_pcall_31(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26]); + 28: t_pcall_32(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27]); + 29: t_pcall_33(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28]); + 30: t_pcall_34(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29]); + 31: t_pcall_35(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30]); + 32: t_pcall_36(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31]); + 33: t_pcall_37(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32]); + 34: t_pcall_38(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33]); + 35: t_pcall_39(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34]); + 36: t_pcall_40(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35]); + 37: t_pcall_41(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36]); + 38: t_pcall_42(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37]); + 39: t_pcall_43(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38]); + 40: t_pcall_44(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39]); + 41: t_pcall_45(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40]); + 42: t_pcall_46(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41]); + 43: t_pcall_47(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42]); + 44: t_pcall_48(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43]); + 45: t_pcall_49(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44]); + 46: t_pcall_50(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45]); + 47: t_pcall_51(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46]); + 48: t_pcall_52(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47]); + 49: t_pcall_53(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48]); + 50: t_pcall_54(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49]); + 51: t_pcall_55(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50]); + 52: t_pcall_56(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51]); + 53: t_pcall_57(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52]); + 54: t_pcall_58(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53]); + 55: t_pcall_59(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54]); + 56: t_pcall_60(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55]); + 57: t_pcall_61(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], + R.S[56]); + 58: t_pcall_62(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], + R.S[56],R.S[57]); + 59: t_pcall_63(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], + R.S[56],R.S[57],R.S[58]); + 60: t_pcall_64(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], + R.S[56],R.S[57],R.S[58],R.S[59]); + 61: t_pcall_65(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], + R.S[56],R.S[57],R.S[58],R.S[59],R.S[60]); + 62: t_pcall_66(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], + R.S[56],R.S[57],R.S[58],R.S[59],R.S[60],R.S[61]); + //} + else + raise EInvocationError.Create('Internal: Parameter count exceeded 64'); + end; +end; +{$ENDIF} + +{$IFDEF X64CALL_ASM} + {$IFDEF WINDOWS} type + //{$IFDEF UNICODE_OR_FPC}{$ALIGN 16}{$ENDIF} // For packed record mode + //{$ifdef FPC} + //{$PACKRECORDS 16} + //{$endif} + t_pstask = array[0..61] of IPointer; + p_pstask = ^t_pstask; TRegisters = packed record _RCX, // 0 _RDX, // 8 @@ -22,12 +478,156 @@ type _XMM1, // 32 _XMM2, // 40 _XMM3: Double; // 48 - Stack: Pointer; // 56 - Items: {$IFDEF FPC}PtrUInt{$ELSE}IntPtr{$ENDIF}; // 64 - SingleBits: Integer; // 72 + case byte of + 0:( + Stack: Pointer; // 56 + Items: {$IFDEF FPC}PtrUInt{$ELSE}IntPtr{$ENDIF}; // 64 + SingleBits: Integer; // 72 + ); + 1:(S: p_pstask); + end; + PRegisters=^TRegisters; + +{$IFDEF CPUX64} + + {$IFDEF DELPHI} + {$DEFINE REG_STACK_PTR_OFFSET0} { optional } // ! Successfully on exceptions ! + {$ENDIF} + + {$IFDEF FPC} + {$mode delphi} + {$ASMMODE INTEL} + {.$DEFINE REG_STACK_PTR_OFFSET0} { optional } // ! GPF on exceptions for both asm variants! + {$ENDIF} + +{$ENDIF CPUX64} + +{$IFDEF REG_STACK_PTR_OFFSET0} // ! NEW asm-win-x64 version for delphi and/or fpc ! + +procedure x64call({RCX}Address: Pointer;out {RDX}_RAX: IPointer;var {R8}_XMM0: Double; var {R9}RegInfo: TRegisters); +assembler; {$ifdef FPC}nostackframe;{$endif} + // + // !!! DELPHI: Successfully on exceptions ! + // !!! TODO: FPC: ! GPF on exception ! + // + procedure InvokeErrorParamCount; // The number of parameters exceeded 64 (c_par_max_count) + begin + raise EInvocationError.Create('Internal: Parameter count exceeded 64'); end; + // +const + c_par_max_count = 64; // == $40 + + c_sz_ptr = SizeOf(Pointer); // == 8 + c_arg_count = 4; // == 4 + c_arg_size = c_arg_count * c_sz_ptr; // == 32 + c_loc_count = c_par_max_count + 4; // == 68 + c_params = c_loc_count - c_arg_count + 1; // == 65 + + c_loc_offs_adress = c_loc_count * c_sz_ptr + c_arg_size; // == 576 + c_loc_offs__rax = c_loc_offs_adress + 1*c_sz_ptr; // == 584 + c_loc_offs__xmm0 = c_loc_offs_adress + 2*c_sz_ptr; // == 592 + c_loc_offs_reginfo = c_loc_offs_adress + 4*c_sz_ptr; // == 608 + + //c_reg_packed = ((SizeOf(TRegisters) mod c_sz_ptr) + c_sz_ptr - 1) div c_sz_ptr; // 1 - packed records; 0 - aligned +asm +{$ifdef DELPHI} + .params c_params // There's actually room for c_loc_count, assembler is saving locals for "Address,_RAX,_XMM0,RegInfo" +{$else} // TODO: FPC: GPF on exception + push rbp + sub rsp, $210 + mov rbp, rsp +{$endif} + + mov [rbp+c_loc_offs_adress], Address // save: rcx (@Address) + mov [rbp+c_loc_offs__rax], _RAX // save: rdx (@_RDX) + mov [rbp+c_loc_offs__xmm0], _XMM0 // save: r8 (@_XMM0) + mov [rbp+c_loc_offs_reginfo], RegInfo // save: r9 (@RegInfo) dbg: TRegisters(pointer(R9)^),r -procedure x64call( + // + // check Registers.Items (param count limitation) + // + mov rcx, [RegInfo].TRegisters.Items + test rcx, rcx + jz @@skip_items + + cmp rcx, c_par_max_count-2 + jbe @@frame_is_try + + call InvokeErrorParamCount + +@@frame_is_try: + // + // copy registers: + // source : [RegInfo].TRegisters.Stack + // dest : [rbp + c_arg_count*c_sz_ptr] + // count : rcx + // note : All items on stack should be 16 byte aligned. Caller should have handled that, just copy data here. + // + mov r8, [RegInfo].TRegisters.Stack // source + lea rdx, [rbp + c_arg_count*c_sz_ptr] // dest +@copy_loop: + // copy pointer: + mov rax, [r8] + mov [rdx], rax + // next: + add r8, c_sz_ptr + add rdx, c_sz_ptr + dec rcx + or rcx, rcx + jnz @copy_loop + // next. + // + // copy registers. + +@@skip_items: + + // mov *, [r9].* ; [r9] == [RegInfo] + mov rcx, [RegInfo].TRegisters._RCX + mov rdx, [RegInfo].TRegisters._RDX + mov r8, [RegInfo].TRegisters._R8 + + movsd xmm0,[RegInfo].TRegisters._RCX + movsd xmm1,[RegInfo].TRegisters._RDX + movsd xmm2,[RegInfo].TRegisters._R8 + movsd xmm3,[RegInfo].TRegisters._R9 + + mov r9, [RegInfo].TRegisters._R9 // !!! Overwritten RegInfo (r9) + + call [rbp+c_loc_offs_adress] + + // make result + mov rdx, [rbp+c_loc_offs__rax] // restore: rdx (@_RDX) + mov [rdx], RAX // fill: _RAX + + //movsd [rdx+c_sz_ptr], XMM0 // fill: _XMM0 + mov rdx, [rbp+c_loc_offs__xmm0] // restore: r8 (@_RMM0) + mov [rdx], RAX // fill: _RAX + +{$ifdef DELPHI} +{$else} + lea rsp, [rbp+$210] + pop rbp + + ret +{$endif} +end; + +{$ELSE !IFDEF REG_STACK_PTR_OFFSET0} // ! asm-win-x64 version for delphi and/or fpc ! + + {$undef _demo_x64call_gpf_} + {.$IFDEF DEBUG} + {.$define _demo_x64call_gpf_} { optional } + {.$ENDIF} + +{$ifdef _demo_x64call_gpf_} +procedure demo_x64call_gpf(); +begin + raise Exception.Create('Demo x64 GPF!'); +end; +{$endif} + +procedure x64call( // TODO: ! GPF on exception ! Address: Pointer; out _RAX: IPointer; var _XMM0: Double; @@ -77,7 +677,6 @@ asm movsd xmm1, [rax+32] @g1e: - bt rcx, 2 jnc @g2 cvtsd2ss xmm2, [rax+40] @@ -94,8 +693,6 @@ asm movsd xmm3, [rax+48] @g3e: - - // rbp-16: address of xmm0 bt rcx, 0 @@ -114,12 +711,16 @@ asm mov r8, [rax+16] mov r9, [rax+24] - mov RAX, [rbp-8] // weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in sub RSP, 32 +{$ifdef _demo_x64call_gpf_} + // Demonstration GPF: + call demo_x64call_gpf +{$endif} + call RAX add RSP, 32 // undo the damage done earlier @@ -143,12 +744,17 @@ asm @g5e: - leave ret end; -{$ELSE} +{$ENDIF !IFDEF REG_STACK_PTR_OFFSET0} + +{$ELSE !WINDOWS} // ! Not windows version ! type + //{$IFDEF UNICODE_OR_FPC}{$ALIGN 16}{$ENDIF} // For packed record mode + //{$ifdef FPC} + //{$PACKRECORDS 16} + //{$endif} TRegisters = packed record _RDI, // 0 _RSI, // 8 @@ -166,14 +772,11 @@ type SingleBits: Integer; //104 end; -procedure x64call( +procedure x64call( // TODO: Need check GPF on exception ! Address: Pointer; out _RAX: IPointer; - var Registers: TRegisters; aStack: Pointer; aItems: Integer; var _XMM0: Double); assembler; nostackframe; - - asm (* Registers: RDI: Address @@ -205,9 +808,9 @@ asm @work: {$IFDEF FPC} push qword ptr [rcx] -{$ELSE} +{$ELSE} push [rcx] -{$ENDIF} +{$ENDIF} dec r8 sub rcx,8 @compareitems: @@ -279,7 +882,7 @@ asm movq xmm6,[rax+88] // move quadword to xmm6 from Registers._XMM6 @skipxmm6re: -// xmm7 + // xmm7 bt [rax+104], 7 jnc @skipxmm7 cvtsd2ss xmm7,[rax+96] @@ -288,7 +891,6 @@ asm movq xmm7,[rax+96] // move quadword to xmm7 from Registers._XMM7 @skipxmm7re: - mov RDI, [rax] mov RSI, [rax+ 8] mov RDX, [rax+16] @@ -302,9 +904,9 @@ asm mov rax, [rbp-8] call RAX -// add rsp, 8 + // add rsp, 8 - // add RSP, 32 // undo the damage done earlier + // add rsp, 32 // undo the damage done earlier // copy result back mov rsi, [rbp-16] // _RAX parameter @@ -322,7 +924,6 @@ asm movq [rsi],xmm0 // move quadword to _XMM0 @skipresre: - pop rdx pop r9 // xmm0 pop rsi // _rax @@ -330,17 +931,19 @@ asm leave ret end; -{$ENDIF} +{$ENDIF !WINDOWS} + +{$ENDIF X64CALL_ASM} function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean; var Stack: array of Byte; _RAX: IPointer; -_XMM0: Double; + _XMM0: Double; Registers: TRegisters; -{$IFNDEF WINDOWS} + {$IFNDEF WINDOWS} RegUsageFloat: Byte; -{$ENDIF} + {$ENDIF} RegUsage: Byte; CallData: TPSList; I: Integer; @@ -348,19 +951,18 @@ _XMM0: Double; function rp(p: PPSVariantIFC): PPSVariantIFC; begin - if p = nil then - begin + if (p = nil) or (p.aType = nil) then begin result := nil; exit; end; - if p.aType.BaseType = btPointer then - begin + if p.aType.BaseType = btPointer then begin p^.aType := Pointer(Pointer(IPointer(p^.dta) + PointerSize)^); p^.Dta := Pointer(p^.dta^); end; Result := p; end; -{$IFDEF WINDOWS} + + {$IFDEF WINDOWS} procedure StoreReg(data: IPointer); overload; var p: Pointer; begin @@ -371,12 +973,12 @@ _XMM0: Double; 3: begin inc(RegUsage); Registers._R9:=Data; end; else begin SetLength(Stack, Length(Stack)+8); - p := @Stack[LEngth(Stack)-8]; + p := @Stack[Length(Stack)-8]; IPointer(p^) := data; end; end; end; - {$ELSE} + {$ELSE !WINDOWS} procedure StoreReg(data: IPointer); overload; var p: Pointer; begin @@ -387,14 +989,14 @@ _XMM0: Double; 3: begin inc(RegUsage); Registers._RCX:=Data; end; 4: begin inc(RegUsage); Registers._R8:=Data; end; 5: begin inc(RegUsage); Registers._R9:=Data; end; - else begin - SetLength(Stack, Length(Stack)+8); - p := @Stack[LEngth(Stack)-8]; - IPointer(p^) := data; - end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[Length(Stack)-8]; + IPointer(p^) := data; + end; end; end; -{$ENDIF} + {$ENDIF !WINDOWS} procedure StoreStack(const aData; Len: Integer); var @@ -409,7 +1011,7 @@ _XMM0: Double; Move(aData, p^, Len); end; -{$IFDEF WINDOWS} + {$IFDEF WINDOWS} procedure StoreReg(data: Double); overload; var p: Pointer; begin @@ -418,11 +1020,11 @@ _XMM0: Double; 1: begin inc(RegUsage); Registers._XMM1:=Data; end; 2: begin inc(RegUsage); Registers._XMM2:=Data; end; 3: begin inc(RegUsage); Registers._XMM3:=Data; end; - else begin - SetLength(Stack, Length(Stack)+8); - p := @Stack[LEngth(Stack)-8]; - Double(p^) := data; - end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[Length(Stack)-8]; + Double(p^) := data; + end; end; end; procedure StoreReg(data: Single); overload; @@ -433,14 +1035,14 @@ _XMM0: Double; 1: begin inc(RegUsage); Registers.SingleBits := Registers.SingleBits or 2; Registers._XMM1:=Data; end; 2: begin inc(RegUsage); Registers.SingleBits := Registers.SingleBits or 4;Registers._XMM2:=Data; end; 3: begin inc(RegUsage); Registers.SingleBits := Registers.SingleBits or 8; Registers._XMM3:=Data; end; - else begin - SetLength(Stack, Length(Stack)+8); - p := @Stack[LEngth(Stack)-8]; - Double(p^) := data; - end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[Length(Stack)-8]; + Double(p^) := data; + end; end; end; - {$ELSE} + {$ELSE !WINDOWS} procedure StoreReg(data: Double); overload; var p: Pointer; begin @@ -453,11 +1055,11 @@ _XMM0: Double; 5: begin inc(RegUsageFloat); Registers._XMM5:=Data; end; 6: begin inc(RegUsageFloat); Registers._XMM6:=Data; end; 7: begin inc(RegUsageFloat); Registers._XMM7:=Data; end; - else begin - SetLength(Stack, Length(Stack)+8); - p := @Stack[LEngth(Stack)-8]; - Double(p^) := data; - end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[Length(Stack)-8]; + Double(p^) := data; + end; end; end; procedure StoreReg(data: Single); overload; @@ -472,40 +1074,48 @@ _XMM0: Double; 5: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 32; Registers._XMM5:=Data; end; 6: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 64; Registers._XMM6:=Data; end; 7: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 128; Registers._XMM7:=Data; end; - else begin - SetLength(Stack, Length(Stack)+8); - p := @Stack[LEngth(Stack)-8]; - Double(p^) := data; - end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[Length(Stack)-8]; + Double(p^) := data; + end; end; end; - {$ENDIF} + {$ENDIF !WINDOWS} + + type + TMethodCallData = record + AType: Byte; + Data: TMethod; + end; + PMethodCallData=^TMethodCallData; function GetPtr(fVar: PPSVariantIFC): Boolean; + // [#velter#]: https://github.com/remobjects/pascalscript/pull/107 + // https://github.com/velter/pascalscript/commit/44cefba3328bd9cc041e11715d217c97c97199e7 + // https://github.com/remobjects/pascalscript/pull/107/files#diff-0 var varPtr: Pointer; - //UseReg: Boolean; - //tempstr: tbtstring; p: Pointer; begin Result := False; - if FVar = nil then exit; + if fVar = nil then exit; if fVar.VarParam then begin - case fvar.aType.BaseType of - btArray: - begin - if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then - begin - p := CreateOpenArray(True, Self, FVar); + case fVar.aType.BaseType of + btArray: begin + if Copy(fVar.aType.ExportName, 1, 10) = '!OPENARRAY' then begin + p := CreateOpenArray(True, Self, fVar); if p = nil then exit; + if CallData = nil then // [#velter#] + CallData := TPSList.Create; CallData.Add(p); StoreReg(IPointer(POpenArray(p)^.Data)); StoreReg(IPointer(POpenArray(p)^.ItemCount -1)); Result := True; Exit; end else begin - varptr := fvar.Dta; -// Exit; + varptr := fVar.Dta; + //Exit; end; end; btVariant, @@ -516,123 +1126,120 @@ _XMM0: Double; btClass, {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency - {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: - begin - Varptr := fvar.Dta; + {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: begin + Varptr := fVar.Dta; end; - else begin - exit; //invalid type + else begin + Exit; // invalid type end; end; {case} - StoreReg(IPointer(VarPtr)); - end else begin -// UseReg := True; - case fVar^.aType.BaseType of - btSet: - begin - case TPSTypeRec_Set(fvar.aType).aByteSize of - 1: StoreReg(IPointer(byte(fvar.dta^))); - 2: StoreReg(IPointer(word(fvar.dta^))); - 3, 4: StoreReg(IPointer(cardinal(fvar.dta^))); + end else begin { #else : (not fVar.VarParam) } + case fVar.aType.BaseType of + btSet: begin + case TPSTypeRec_Set(fVar.aType).aByteSize of + 1: StoreReg(IPointer(byte(fVar.dta^))); + 2: StoreReg(IPointer(word(fVar.dta^))); + 3, 4: StoreReg(IPointer(cardinal(fVar.dta^))); 5,6,7,8: StoreReg(IPointer(fVar.Dta^)); else - StoreReg(IPointer(fvar.Dta)); + StoreReg(IPointer(fVar.Dta)); end; end; - btArray: - begin - if Copy(fvar^.aType.ExportName, 1, 10) = '!OPENARRAY' then - begin - p := CreateOpenArray(False, SElf, FVar); + btArray: begin + if Copy(fVar.aType.ExportName, 1, 10) = '!OPENARRAY' then begin + p := CreateOpenArray(False, Self, fVar); if p =nil then exit; + if CallData = nil then // [#velter#] + CallData := TPSList.Create; CallData.Add(p); StoreReg(IPointer(POpenArray(p)^.Data)); StoreReg(IPointer(POpenArray(p)^.ItemCount -1)); Result := True; exit; end else begin - {$IFDEF FPC} - StoreReg(IPointer(FVar.Dta)); - {$ELSE} - StoreReg(IPointer(FVar.Dta^)); - {$ENDIF} + StoreReg(IPointer(fVar.Dta{$IFNDEF FPC}^{$ENDIF})); end; end; - btRecord: - begin - if fvar^.aType.RealSize <= sizeof(IPointer) then - StoreReg(IPointer(fvar.dta^)) + btRecord: begin + if fVar.aType.RealSize <= sizeof(IPointer) then + StoreReg(IPointer(fVar.dta^)) else StoreReg(IPointer(fVar.Dta)); end; - btVariant - , btStaticArray: - begin + btVariant, btStaticArray: begin StoreReg(IPointer(fVar.Dta)); end; btExtended, btDouble: {8 bytes} begin - StoreReg(double(fvar.dta^)); + StoreReg(double(fVar.dta^)); end; btCurrency: {8 bytes} begin - StoreReg(IPointer(fvar.dta^)); + StoreReg(IPointer(fVar.dta^)); end; btSingle: {4 bytes} begin - StoreReg(single(fvar.dta^)); + StoreReg(single(fVar.dta^)); end; - btChar, - btU8, - btS8: begin - StoreReg(IPointer(byte(fVar^.dta^))); + btChar, btU8, btS8: begin + StoreReg(IPointer(byte(fVar.dta^))); end; btWideChar, - btu16, btS16: begin - StoreReg(IPointer(word(fVar^.dta^))); + btU16, btS16: begin + StoreReg(IPointer(word(fVar.dta^))); end; - btu32, bts32: begin - StoreReg(IPointer(cardinal(fVar^.dta^))); + btU32, btS32: begin + StoreReg(IPointer(cardinal(fVar.dta^))); end; - btPchar: - begin - if pointer(fvar^.dta^) = nil then - StoreReg(IPointer(@EmptyPchar)) + btPChar: begin + if Pointer(fVar.dta^) = nil then + StoreReg(IPointer(@EmptyPChar)) else - StoreReg(IPointer(fvar^.dta^)); + StoreReg(IPointer(fVar.dta^)); end; - btclass, btinterface, btString: - begin - StoreReg(IPointer(fvar^.dta^)); + btClass, btInterface, btString: begin + StoreReg(IPointer(fVar.dta^)); end; btWideString: begin - StoreReg(IPointer(fvar^.dta^)); + StoreReg(IPointer(fVar.dta^)); end; btUnicodeString: begin - StoreReg(IPointer(fvar^.dta^)); + StoreReg(IPointer(fVar.dta^)); end; - - btProcPtr: - begin + btProcPtr: begin + // [#velter#]: + { GetMem(p, PointerSize2); - TMethod(p^) := MKMethod(Self, Longint(FVar.Dta^)); + TMethod(p^) := MKMethod(Self, Longint(fVar.Dta^)); StoreStack(p^, Pointersize2); FreeMem(p); + } + //GetMem(p, sizeof(TMethodCallData)); + p := New(PMethodCallData); + TMethodCallData(p^).AType:=255; + if CallData = nil then + CallData := TPSList.Create; + CallData.Add(p); + TMethodCallData(p^).Data.Code:=nil; + //TMethodCallData(p^).Data.Data:=nil; + TMethodCallData(p^).Data := MKMethod(Self, Longint(fVar.Dta^)); // It requires the implementation of "Handled" + StoreReg(IPointer(@TMethodCallData(p^).Data)); + // [#velter#]. + end; + btS64: begin + StoreReg(IPointer(int64(fVar.dta^))); end; - - bts64: - begin - StoreReg(IPointer(int64(fvar^.dta^))); - end; end; {case} - end; + end; { #if else : (not fVar.VarParam) } Result := True; - end; -begin + end; // function GetPtr + +begin // function TPSExec.InnerfuseCall + // TODO: FPC: OpenArray fail (AV). Sample script: "begin format('%s; %s',['2','2']); end." InnerfuseCall := False; if Address = nil then exit; // need address SetLength(Stack, 0); - CallData := TPSList.Create; + CallData := nil; // [#velter#] res := rp(res); if res <> nil then res.VarParam := true; @@ -646,8 +1253,8 @@ begin _XMM7 := 0;*) RegUsageFloat := 0; {$ENDIF} - _XMM0 := 0; - FillChar(Registers, Sizeof(REgisters), 0); + _XMM0 := 0; + FillChar(Registers, Sizeof(Registers), 0); _RAX := 0; RegUsage := 0; if assigned(_Self) then begin @@ -656,28 +1263,37 @@ begin if assigned(res) and (res^.atype.basetype = btSingle) then begin Registers.Singlebits := Registers.Singlebits or 256; end; -{$IFDEF PS_RESBEFOREPARAMETERS} - if assigned(res) then begin - case res^.aType.BaseType of - {$IFDEF x64_string_result_as_varparameter} - btstring, btWideString, btUnicodeString, - {$ENDIF} - btInterface, btArray, btVariant, btStaticArray: - GetPtr(res); - btRecord, - btSet: - begin - if res.aType.RealSize > PointerSize then GetPtr(res); - end; + {$IFDEF PS_RESBEFOREPARAMETERS} + if assigned(res) then begin + case res^.aType.BaseType of + {$IFDEF x64_string_result_as_varparameter} + {$IFNDEF PS_NOWIDESTRING} + btWideString, btUnicodeString, + {$ENDIF} + {.$IFNDEF PS_FPCSTRINGWORKAROUND} + btString, + {.$ENDIF} + {$ENDIF x64_string_result_as_varparameter} + {$IFNDEF FPC} + btArray, + {$ENDIF} + btInterface, btVariant, btStaticArray: + GetPtr(res); + btRecord, + btSet: + begin + if res.aType.RealSize > PointerSize then + GetPtr(res); + end; + end; end; - end; -{$ENDIF} - for I := 0 to Params.Count - 1 do - begin - if not GetPtr(rp(Params[I])) then Exit; + {$ENDIF PS_RESBEFOREPARAMETERS} + for I := 0 to Params.Count - 1 do begin + if not GetPtr(rp(Params[I])) then + Exit; end; if assigned(res) then begin -{$IFNDEF PS_RESBEFOREPARAMETERS} + {$IFNDEF PS_RESBEFOREPARAMETERS} case res^.aType.BaseType of {$IFDEF x64_string_result_as_varparameter} btstring, btWideString, btUnicodeString, @@ -687,23 +1303,28 @@ begin btRecord, btSet: begin - if res.aType.RealSize > PointerSize then GetPtr(res); + if res.aType.RealSize > PointerSize then + GetPtr(res); end; end; -{$ENDIF} + {$ENDIF !PS_RESBEFOREPARAMETERS} {$IFDEF WINDOWS} if (length(Stack) mod 16) <> 0 then begin SetLength(Stack, Length(Stack)+16 - (Length(Stack) mod 16)); end; - {$ENDIF} - if Stack = nil then pp := nil else pp := @Stack[Length(Stack) -8]; -{$IFDEF WINDOWS} + {$ENDIF} + if Stack = nil + then pp := nil + else pp := @Stack[{$IFDEF REG_STACK_PTR_OFFSET0}0{$ELSE}Length(Stack)-8{$ENDIF}]; + + {$IFDEF WINDOWS} Registers.Stack := pp; Registers.Items := Length(Stack) div 8; x64call(Address, _RAX, _XMM0, Registers); -{$ELSE} + {$ELSE} x64call(Address, _RAX, Registers, pp, Length(Stack) div 8, _XMM0); -{$ENDIF} + {$ENDIF !WINDOWS} + case res^.aType.BaseType of btRecord, btSet: begin @@ -715,54 +1336,80 @@ begin 5,6,7,8: IPointer(res.dta^) := _RAX; end; end; - btSingle: tbtsingle(res.Dta^) := _XMM0; - btDouble: tbtdouble(res.Dta^) := _XMM0; - btExtended: tbtextended(res.Dta^) := _XMM0; - btchar,btU8, btS8: tbtu8(res.dta^) := _RAX; - btWideChar, btu16, bts16: tbtu16(res.dta^) := _RAX; - btClass : IPointer(res.dta^) := _RAX; - btu32,bts32: tbtu32(res.dta^) := _RAX; - btPChar: pansichar(res.dta^) := Pansichar(_RAX); - bts64: tbts64(res.dta^) := Int64(_RAX); - btCurrency: tbts64(res.Dta^) := Int64(_RAX); + btSingle: + tbtsingle(res.Dta^) := _XMM0; + btDouble: + tbtdouble(res.Dta^) := _XMM0; + btExtended: + tbtextended(res.Dta^) := _XMM0; + btchar,btU8, btS8: + tbtu8(res.dta^) := _RAX; + + {$IFNDEF PS_NOWIDESTRING} + btWideChar, + {$ENDIF} + btu16, bts16: tbtu16(res.dta^) := _RAX; + + btClass : + IPointer(res.dta^) := _RAX; + btu32,bts32: + tbtu32(res.dta^) := _RAX; + btPChar: + pansichar(res.dta^) := Pansichar(_RAX); + bts64: + tbts64(res.dta^) := Int64(_RAX); + btCurrency: + tbtCurrency(res.Dta^) := Int64(_RAX); + btInterface, btVariant, {$IFDEF x64_string_result_as_varparameter} - btWidestring,btUnicodestring, btstring , + btWidestring, btUnicodestring, btString, {$ENDIF} btStaticArray, btArray:; + {$IFNDEF x64_string_result_as_varparameter} - btUnicodeString, btWideString, btstring: Int64(res.dta^) := _RAX; + btUnicodeString, btWideString, btstring: + Int64(res.dta^) := _RAX; {$ENDIF} else exit; - end; - end else begin + end; // case + end else begin // when res==nil {$IFDEF WINDOWS} if (length(Stack) mod 16) <> 0 then begin SetLength(Stack, Length(Stack)+16 - (Length(Stack) mod 16)); end; - {$ENDIF} - if Stack = nil then pp := nil else pp := @Stack[Length(Stack) -8]; -{$IFDEF WINDOWS} - Registers.Stack := pp; - Registers.Items := Length(Stack) div 8; - x64call(Address, _RAX, _XMM0, Registers); -{$ELSE} - x64call(Address, _RAX, Registers, pp, Length(Stack) div 8, _XMM0); -{$ENDIF} - end; + {$ENDIF} + if Stack = nil + then pp := nil + else pp := @Stack[{$IFDEF REG_STACK_PTR_OFFSET0}0{$ELSE}Length(Stack)-8{$ENDIF}]; + + {$IFDEF WINDOWS} + Registers.Stack := pp; + Registers.Items := Length(Stack) div 8; + x64call(Address, _RAX, _XMM0, Registers); + {$ELSE} + x64call(Address, _RAX, Registers, pp, Length(Stack) div 8, _XMM0); + {$ENDIF !WINDOWS} + end; // if else Result := True; finally - for i := CallData.Count -1 downto 0 do - begin - pp := CallData[i]; - case pp^ of - 0: DestroyOpenArray(Self, Pointer(pp)); + if Assigned(CallData) then begin + for i := CallData.Count-1 downto 0 do + begin + pp := CallData[i]; + case pp^ of + 0: begin + DestroyOpenArray(Self, Pointer(pp)); + end; + 255: begin // [#velter#]: https://github.com/velter/pascalscript/commit/1c598a1406390e2e762368b07a185ecb187182a7 + //FreeMem(Pointer(pp), sizeof(TMethodCallData)); // release TMethodCallData + Dispose(PMethodCallData(pp)); + end; + end; end; + CallData.Free; end; - CallData.Free; end; end; - - From 516bc2ef993bd4b22956fe789abe29ce159558af Mon Sep 17 00:00:00 2001 From: Vadim Lou Date: Tue, 21 Mar 2017 19:22:28 +0200 Subject: [PATCH 2/9] Sample : Exception handling - sample: {$i inc-file} - sample: params 7, 64 - sample: raise exception ( procedure RaiseExceptionMessage ) - sample: show current exception: text,file,position - sample: emulate reserved word "raise" ( raise current exception ) - TODO: AV: FPC X64 OPENARRAY ( sample "format('%s; %s',['2','2'])" ) --- Samples/console_rops/cfg_dcc.cmd | 57 + Samples/console_rops/clean.cmd | 8 + Samples/console_rops/console_rops.dpr | 105 + Samples/console_rops/console_rops.inc | 557 ++++++ Samples/console_rops/console_rops.lpr | 162 ++ Samples/console_rops/console_rops.res | Bin 0 -> 1004 bytes .../console_rops/console_rops_test_fp64.inc | 100 + Samples/console_rops/ide.zip | Bin 0 -> 20636 bytes Samples/console_rops/make_d2007.bat | 1 + Samples/console_rops/make_dx10.1_win32.bat | 1 + Samples/console_rops/make_dx10.1_win64.bat | 1 + Samples/console_rops/make_prj.cmd | 1738 +++++++++++++++++ Samples/console_rops/make_xe3_win32.bat | 1 + Samples/console_rops/make_xe3_win64.bat | 1 + .../console_rops/rops_inc/sample_include.inc | 11 + Samples/console_rops/sample_default.rops | 9 + Samples/console_rops/sample_exception.rops | 3 + .../console_rops/sample_exception_handle.rops | 36 + .../console_rops/sample_format_openarray.rops | 56 + .../sample_format_openarray7s.rops | 9 + .../sample_format_openarray_fpc_x64_err0.rops | 4 + .../sample_format_openarray_fpc_x64_err1.rops | 9 + Samples/console_rops/sample_hello.rops | 4 + Samples/console_rops/sample_include.rops | 8 + .../console_rops/sample_test_params64.rops | 18 + Samples/console_rops/sample_test_params7.rops | 9 + 26 files changed, 2908 insertions(+) create mode 100644 Samples/console_rops/cfg_dcc.cmd create mode 100644 Samples/console_rops/clean.cmd create mode 100644 Samples/console_rops/console_rops.dpr create mode 100644 Samples/console_rops/console_rops.inc create mode 100644 Samples/console_rops/console_rops.lpr create mode 100644 Samples/console_rops/console_rops.res create mode 100644 Samples/console_rops/console_rops_test_fp64.inc create mode 100644 Samples/console_rops/ide.zip create mode 100644 Samples/console_rops/make_d2007.bat create mode 100644 Samples/console_rops/make_dx10.1_win32.bat create mode 100644 Samples/console_rops/make_dx10.1_win64.bat create mode 100644 Samples/console_rops/make_prj.cmd create mode 100644 Samples/console_rops/make_xe3_win32.bat create mode 100644 Samples/console_rops/make_xe3_win64.bat create mode 100644 Samples/console_rops/rops_inc/sample_include.inc create mode 100644 Samples/console_rops/sample_default.rops create mode 100644 Samples/console_rops/sample_exception.rops create mode 100644 Samples/console_rops/sample_exception_handle.rops create mode 100644 Samples/console_rops/sample_format_openarray.rops create mode 100644 Samples/console_rops/sample_format_openarray7s.rops create mode 100644 Samples/console_rops/sample_format_openarray_fpc_x64_err0.rops create mode 100644 Samples/console_rops/sample_format_openarray_fpc_x64_err1.rops create mode 100644 Samples/console_rops/sample_hello.rops create mode 100644 Samples/console_rops/sample_include.rops create mode 100644 Samples/console_rops/sample_test_params64.rops create mode 100644 Samples/console_rops/sample_test_params7.rops diff --git a/Samples/console_rops/cfg_dcc.cmd b/Samples/console_rops/cfg_dcc.cmd new file mode 100644 index 00000000..48700b7d --- /dev/null +++ b/Samples/console_rops/cfg_dcc.cmd @@ -0,0 +1,57 @@ +@echo off + +rem Common options + + set UsePack=0 + set EurekaLog=0 + set DEBUG=0 + set MAPFILE=0 + set JDBG=0 + set CleanDcc32Log=1 + set DEBUG_BATCH=0 + set TRACE_STACK_SOURCE=0 + + set UserLib=. + + rem . RemObjects Pascal Components path: + set rps_lib=..\.. + rem . + set UserLib=%UserLib%;%rps_lib%\Source;%rps_lib%\Source\ThirdParty + +:L_LIB_DONE + set UserLibI=%UserLib% + set UserLibR=%UserLib% + + @rem dcc analyze result options: + @rem @set IGNOREERRORLEVEL=1 + + @rem MakeJclDbg + @rem J - Create .JDBG files + @rem E - Insert debug data into executable files + @rem M - Delete MAP file after conversion + @if "%plfm%"=="w32" set MakeJclDbgO=-E + + @rem path to MakeJclDbg.exe + @set MakeJclDbgP=%cd%\thirdparty\jcl\ + +:L_DCU + if "%plfm%"=="" set plfm=w32 + +:L_EXE + @rem @if "%plfm%"=="w64" set UserCOpt=%UserCOpt% -E.\..\bin\x64 + @rem @if "%plfm%"=="w32" @set UserCOpt=%UserCOpt% -E.\..\bin + +:L_DCU_A +@goto L_DCU_L + @rem "A:" - it is RAMDisk (ImDisk: http://www.ltr-data.se/opencode.html/#ImDisk) + @if not exist "A:\" goto L_DCU_L + @if not exist "A:\$dx\%plfm%__dcu\" md "A:\$dx\%plfm%__dcu" + @if not exist "A:\$dx\%plfm%__dcu\" goto L_DCU_L + @set UserCOpt=%UserCOpt% -N0A:\$dx\%plfm%__dcu + @goto :eof + +:L_DCU_L + @if not exist ".\_dcu\" md ".\_dcu" + @if not exist ".\_dcu\" goto :eof + @set UserCOpt=%UserCOpt% -N0.\_dcu + @goto :eof diff --git a/Samples/console_rops/clean.cmd b/Samples/console_rops/clean.cmd new file mode 100644 index 00000000..16cf081b --- /dev/null +++ b/Samples/console_rops/clean.cmd @@ -0,0 +1,8 @@ +@del /S *.dcu;*.drc;*.dex;*.rsm;*.~*>nul 2>nul +@del dcc32.log>nul 2>nul + +@if exist _dcu ( + pushd _dcu + del /Q *.*>nul 2>nul + popd +) diff --git a/Samples/console_rops/console_rops.dpr b/Samples/console_rops/console_rops.dpr new file mode 100644 index 00000000..d96b5d9b --- /dev/null +++ b/Samples/console_rops/console_rops.dpr @@ -0,0 +1,105 @@ +program console_rops; +// Delphi project +{$apptype console} +{$R console_rops.res} +// +// make: +// D2007 +// make_prj.cmd 11 console_rops.dpr +// XE3 +// make_prj.cmd 17 console_rops.dpr +// make_prj.cmd 17w64 console_rops.dpr +// DX 10.1 Berlin +// make_prj.cmd 24w32 console_rops.dpr +// make_prj.cmd 24w64 console_rops.dpr +// +// sample run: +// +//> console_rops.exe sample_hello.rops +// +uses + SysUtils, Classes, Windows, + uPSDebugger, uPSComponent, uPSUtils, + uPSCompiler, uPSRuntime; + +{$i console_rops.inc} + +const + Script : string = 'var s: string; begin s := ''Hello script :)''; writeln(S); end.'; +var + ScriptFile: string; + ErrorLevel: integer; +begin + // + // parse params + // + if (ParamCount>0) then begin + if SameText(ExtractFileExt(ParamStr(1)),'.rops') then begin + ScriptFile := ParamStr(1); + end else begin + DoStrWriteLn(''); + DoStrWriteLn('Usage as: console_rops.exe *.rops'); + DoStrWriteLn(''); + if (ScriptFile = '/?') or (ScriptFile = '/?help') or (ScriptFile = '-help') or (ScriptFile = '/?') then + Exit + else + Halt(2); + end; + end else begin + ScriptFile := ExtractFilePath(ParamStr(0)) + PathDelim + 'sample_default.rops'; + if not FileExists(ScriptFile) then + ScriptFile := ''; + end; + if ScriptFile <> '' then begin + ScriptsFolder := ExtractFilePath(ScriptFile); + if ScriptsFolder = '' then + ScriptsFolder := GetCurrentDir(); + end else begin + //--ScriptsFolder := ExtractFilePath(ParamStr(0)); + ScriptsFolder := GetCurrentDir(); + end; + // + // go: ... + // + ErrorLevel := 1; + DoStrWriteLn; + + {$IFDEF CPUX64} + DoStrWriteLn('# CPUX64'); + {$ELSE} + {$IFDEF CPU64} + DoStrWriteLn('# CPU64'); + {$ELSE} + {$IFDEF 32BIT} + DoStrWriteLn('# 32BIT'); + {$ELSE} + {.$IFNDEF UNICODE}{$IFNDEF FPC} + DoStrWriteLn('# X86'); + {$ENDIF}{.$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + + DoStrWriteLn('Demo start: file: "' + ExtractFileName(ScriptFile) + '"'); + DoStrWriteLn('-----------'); + try + + ErrorLevel := ExecuteScript(Script, ScriptFile); + + DoStrWriteLn('-----------'); + + if ErrorLevel <> 0 + then DoStrWriteLn('Demo failed.') + else DoStrWriteLn('Demo finish.'); + except + on e: Exception do + begin + DoStrWriteLn; + DoStrWriteLn('Exception: '+Format('Class: %s; Message: %s',[e.ClassName,e.Message])); + end; + end; + DoStrWriteLn; + writeln('# errorlevel == '+inttostr(ErrorLevel)); + if ErrorLevel <> 0 then + Halt(ErrorLevel); +end. diff --git a/Samples/console_rops/console_rops.inc b/Samples/console_rops/console_rops.inc new file mode 100644 index 00000000..6c05f61f --- /dev/null +++ b/Samples/console_rops/console_rops.inc @@ -0,0 +1,557 @@ +{ console_rops.inc } + +procedure dbg(const L: string); inline; +begin + {$IFDEF MSWINDOWS} + OutputDebugString(PChar('dbg:> '+StringReplace(TrimRight(L),#9,#32#32,[rfReplaceAll]))); + {$ELSE} + writeln('dbg:> '+TrimRight(L),#9,#32#32,[rfReplaceAll]); + {$ENDIF} +end; + +procedure DoStrWriteLn(const L: string = ''); +begin + if IsConsole then + writeln(L) + else + dbg(L); +end; + +procedure StrWriteLn(S: string = ''); +var + L: string; +begin + //--S := TrimRight(S); + L := FormatDateTime('yyyy-mm-dd hh:mm:ss:zzz', Now); + if Length(S) > 0 then + L := L + ' # ' + S + else + L := L + ' #'; + DoStrWriteLn(L); +end; + +function script_Format(const AFormat: string; const Args: array of const): string; +// x.AddDelphiFunction('function Format( const Format : string; const Args : array of const) : string'); +// Sender.Exec.RegisterDelphiFunction(@Format, 'Format', cdRegister); +// or +// Sender.Exec.RegisterDelphiFunction(@script_Format, 'Format', cdRegister); +var + i, ArgsLen: integer; + p: pointer; + s: string; + //iPos: integer; + //} +begin + //Result := ''; + (* + s := AFormat; + ArgsLen := Length(Args); + if ArgsLen > 0 then begin + i := 0; + iPos := pos('%s', s); + while (iPos > 0) and (i < ArgsLen) do begin + s := stringreplace(s, '%s', string(Args[i].VChar), []); + inc(i); + iPos := pos('%s', s); + end; + end; + Result := s;//*) + //(* + ArgsLen := Length(Args); + if ArgsLen = 0{1} then begin + //Result := Format(AFormat, Args); + Result := AFormat; + Exit; + end; + //writeln(' # Length(Args): '+inttostr(ArgsLen)); + for i := 0 to ArgsLen-1 do begin // check memory access + //case Args[i].VType of + p := Args[i].VPointer; + if p = nil then + dbg('error: args['+string(inttostr(i))+']'); + //s := string(Args[i].VChar); + end;//} + s := Format(AFormat, Args); + Result := s; + //*) +end; + +function script_test_params7(p1: Integer; p2, p3: string; b4: Boolean; d5: Double; ca6: Char; cw7: Char): string; +// x.AddDelphiFunction('function test_params7(p1: Integer; p2, p3: string; b4: Boolean; d5: Double; ca6: Char; cw7: Char): string'); +// Sender.Exec.RegisterDelphiFunction(@script_test_params7, 'test_params7', cdRegister); +begin + Result := Format('p1: %d; p2: %s; p3: %s; b4: %d; d5: %f; ca6: %s; cw7: %s',[p1,p2,string(p3),byte(b4),d5,string(ca6),string(cw7)]); +end; + +function script_test_openArray7s(args: array of const): string; +// x.AddDelphiFunction('function test_openArray7s(args: array of const): string'); +// Sender.Exec.RegisterDelphiFunction(@script_test_openArray7s, 'test_openArray7s', cdRegister); +begin + if Length(args) = 7 + then Result := Format('p1: %s; p2: %s; p2: %s; p4: %s; p5: %s; p6: %s; p7: %s;',args) + else Result := 'warn: required 7 string parameters'; +end; + +{$i console_rops_test_fp64.inc} // 64 params + +type + EScriptException = class(Exception); +procedure script_RaiseExceptionMessage(s: string); +// x.AddDelphiFunction('procedure RaiseExceptionMessage(s: string)'); +// Sender.Exec.RegisterDelphiFunction(@script_RaiseExceptionMessage, 'RaiseExceptionMessage', cdRegister); +begin + if s = '' then s := 'Script exception'; + raise EScriptException.Create(s); +end; + +var + ScriptsFolder: string; +type + TPSExecAccess = class(TPSExec); + TPSDebugExecAccess = class(TPSDebugExec); + EScriptRaise = class(EAbort) // Exception + EClass: ExceptClass; + ExProc, ExPos: Cardinal; + eRow, eCol: Cardinal; + sFn: uPSUtils.tbtString; + ExParam: uPSUtils.tbtString; + constructor Create(PSExec: TPSExec); overload; + end; + TPSDebugExecRaise = class(TPSDebugExec) // implemented raise + protected + procedure ExceptionProc(proc, Position: Cardinal; Ex: TPSError; const s: tbtstring; NewObject: TObject); override; + // + function script_ExceptionText(): string; + procedure script_RaiseCurrentException(); + end; + {$if not Declared(TPSExceptionHandler)} // uPSRuntime.pas implementaion + TPSExceptionHandlerHack = class + CurrProc: TPSInternalProcRec; + BasePtr, StackSize: Cardinal; + FinallyOffset, ExceptOffset, Finally2Offset, EndOfBlock: Cardinal; + ExceptionData: TPSError; + CurrentExceptionObject: TObject; // !!! required access + ExceptionParam: tbtString; + end; + TPSExceptionHandler = TPSExceptionHandlerHack; + {$ifend} +constructor EScriptRaise.Create(PSExec: TPSExec); +var + FExceptionStack: TPSList; + E: TObject; +var + DExec: TPSDebugExecAccess; + ePos: Cardinal; +begin + EClass := Exception; + if (TPSExecAccess(PSExec).ExObject is Exception) then begin + EClass := ExceptClass(Exception(TPSExecAccess(PSExec).ExObject).ClassType); + end else begin + FExceptionStack := TPSExecAccess(PSExec).FExceptionStack; + if FExceptionStack.Count > 0 then begin + E := TPSExceptionHandler(FExceptionStack[FExceptionStack.Count-1]).CurrentExceptionObject; + if Assigned(E) and (E is Exception) then begin + EClass := ExceptClass(E.ClassType); + end; + end; + end; + + ExParam := TPSExecAccess(PSExec).ExParam; + if PSExec is TPSDebugExec then begin + DExec := TPSDebugExecAccess(PSExec); + if DExec.TranslatePositionEx(DExec.ExProc, DExec.ExPos, ePos, eRow, eCol, sFn) then begin + ExProc := DExec.ExProc; + ExPos := DExec.ExPos; + end; + end; + + inherited Create('internal: raise'); +end; +procedure TPSDebugExecRaise.ExceptionProc(proc, Position: Cardinal; Ex: TPSError; const s: tbtstring; NewObject: TObject); +var + E: EScriptRaise; + ERaise: Exception; +begin + if Assigned(NewObject) and (NewObject.ClassType = EScriptRaise) then begin + try + E := EScriptRaise(NewObject); + // restore state: + FCurrentRow := E.eRow; // for show error pos in "function ExecuteScript" + FCurrentCol := E.eCol; // for show error pos in "function ExecuteScript" + FCurrentFile := E.sFn; // for show error pos in "function ExecuteScript" + //ExProc := E.ExProc; + //ExPos := E.ExPos; + //ExParam := E.ExParam; + // restore state. + + ERaise := E.EClass.Create(string(E.ExParam)); // simple clone exception (no clone extended fields) + inherited ExceptionProc(E.ExProc, E.ExPos, erException, E.ExParam, {NewObject:}ERaise); + finally + NewObject.Free; + end; + end + else + inherited ExceptionProc(proc, Position, Ex, s, NewObject); +end; +function CompactScriptFileName(const sFile, ScriptsFolder: string): string; +begin + if (sFile <> '') then begin + Result := ScriptsFolder + PathDelim; + if SameText(Result, Copy(sFile, 1, Length(Result))) then begin + Result := Copy(sFile, Length(Result)+1, Length(sFile)); + Exit; + end; + end; + Result := ExtractFilename(sFile); +end; +function TPSDebugExecRaise.script_ExceptionText(): string; +// x.AddDelphiFunction('function ExceptionText: string'); +// Sender.Exec.RegisterDelphiMethod(Self, @TPSDebugExecRaise.script_ExceptionText, 'ExceptionText', ACallType); +var + DExec: TPSDebugExecAccess; + eRow, eCol: Cardinal; + ePos: Cardinal; + sFn: uPSUtils.tbtString; +var + ASelf: TPSExec; +begin + ASelf := Self; + Result := string(TPSExecAccess(ASelf).ExParam); + if ASelf is TPSDebugExec then begin + DExec := TPSDebugExecAccess(ASelf); + if DExec.TranslatePositionEx(DExec.ExceptionProcNo, DExec.ExceptionPos, ePos, eRow, eCol, sFn) then begin + Result := Format('Message: "%s"; File: "%s"; Pos: (%d, %d)', [ + {message:}Result, + {file:}CompactScriptFileName(string(sFn), ScriptsFolder), + {position:}eRow, eCol]); + //dbg('ERROR: '+Result); + end; + end; +end; +procedure TPSDebugExecRaise.script_RaiseCurrentException(); +// x.AddDelphiFunction('procedure raise'); +// Sender.Exec.RegisterDelphiMethod(Sender.Exec, @TPSDebugExecRaise.script_RaiseCurrentException, 'raise', cdRegister); +var + ASelf: TPSExec; +begin + ASelf := Self; + if ASelf.ExceptionObject <> nil then begin // ASelf.ExecErrorCode == erException + ASelf.RaiseCurrentException; + end else if TPSExecAccess(ASelf).FExceptionStack.Count > 0 then begin + raise EScriptRaise.Create(ASelf); + + {FExceptionStack := TPSExecAccess(PSExec).FExceptionStack; + E := TPSExceptionHandler(FExceptionStack[FExceptionStack.Count-1]).ExceptionObject; + if Assigned(E) then begin + FExceptionStack.DeleteLast; + raise E; + end;} + end; +end; +procedure PSScript_CompImport(ASelf: TPSScript; Sender: TObject; x: TPSPascalCompiler); +begin + x.AddDelphiFunction('procedure dbg(const L: string)'); // OutputDebugString + x.AddDelphiFunction('procedure WriteLn(S: string)'); + x.AddDelphiFunction('function Format( const Format : string; const Args : array of const) : string'); + x.AddDelphiFunction('procedure RaiseExceptionMessage(s: string)'); + x.AddDelphiFunction('function ExceptionText: string'); + x.AddDelphiFunction('procedure raise'); + + // asm call tests: + x.AddDelphiFunction('function test_params7(p1: Integer; p2, p3: string; b4: Boolean; d5: Double; ca6: Char; cw7: Char): string'); + x.AddDelphiFunction('function test_openArray7s(args: array of const): string'); + x.AddDelphiFunction(fp64_decl()); +end; +procedure PSScript_Compile(ASelf: TPSScript; Sender: TPSScript); +begin + Sender.Exec.RegisterDelphiFunction(@dbg, 'dbg', cdRegister); + Sender.Exec.RegisterDelphiFunction(@StrWriteLn, 'WriteLn', cdRegister); + +// Sender.Exec.RegisterDelphiFunction(@Format, 'Format', cdRegister); + Sender.Exec.RegisterDelphiFunction(@script_Format, 'Format', cdRegister); + + Sender.Exec.RegisterDelphiFunction(@script_RaiseExceptionMessage, 'RaiseExceptionMessage', cdRegister); + Sender.Exec.RegisterDelphiMethod(Sender.Exec, @TPSDebugExecRaise.script_ExceptionText, 'ExceptionText', cdRegister); + Sender.Exec.RegisterDelphiMethod(Sender.Exec, @TPSDebugExecRaise.script_RaiseCurrentException, 'raise', cdRegister); + + // asm call tests: + Sender.Exec.RegisterDelphiFunction(@script_test_params7, 'test_params7', cdRegister); + Sender.Exec.RegisterDelphiFunction(@script_test_openArray7s, 'test_openArray7s', cdRegister); + Sender.Exec.RegisterDelphiFunction(@script_fp64, 'fp64', cdRegister); + +// {$IFDEF VCL} +// // Application: +// Sender.AddRegisteredVariable('APPLICATION', 'TApplication'); +// {$ENDIF VCL} +end; +procedure PSScript_Execute(ASelf: TPSScript; Sender: TPSScript); +begin +// {$IFDEF VCL} +// // Application: +// PSScript.SetVarToInstance('APPLICATION', Application); +// {$ENDIF VCL} +end; +function PSScript_NeedFile(ASelf: TPSScript; Sender: TObject; const OrginFileName: tbtString; + var FileName, Output: tbtString): Boolean; +//for include file like: {$i sub\sub_1.inc} +var + i: Integer; + sFileName, sPath, sFileSource: string; + sCode: tbtString; + OK: Boolean; +begin + Result := False; + OK := False; + + sFileName := string(FileName); + + i := Length(OrginFileName); + if i > 0 then begin + sPath := string(OrginFileName); + sPath := ExtractFilePath(sPath); + i := Length(sPath); + {$IFDEF MSWINDOWS} // name like: {$i sub\sub_1.inc} + if (i>2) then begin + if (sPath[2] <> ':') + or ( + (sPath[1] <> '\') and (sPath[2] <> '\') + ) + then + i := 0; + end; + {$ENDIF MSWINDOWS} + if (i>0) then begin + if (sPath[i]=PathDelim) then begin + SetLength(sPath, i-1); + dec(i); + end; + if (i>0) then begin + if sPath = PathDelim then + sPath := ''; + sFileSource := sPath + PathDelim + sFileName; + OK := FileExists(sFileSource); + end; + end else begin + if ScriptsFolder <> '' + then sFileSource := ScriptsFolder + PathDelim + sFileName + else sFileSource := sFileName; + OK := FileExists(sFileSource); + end; + end; + // + if OK then begin + with TStringList.Create do + try + try + LoadFromFile(sFileSource); + sCode := tbtString(Text); + Result := True; + except + end; + finally + Free; + end; + if Result then begin + Output := sCode; + FileName := tbtString(sFileSource); + end; + end; +end; +procedure PSExec_OnException(Sender: TPSExec; ExError: TPSError; const ExParam: tbtstring; ExObject: TObject; ProcNo, Position: Cardinal); +// for traccig all exceptions +var + DExec: TPSDebugExecAccess; + //PSScript: TPSScript; //@dbg + ScriptFile, sMessage: string; + eRow, eCol: Cardinal; + //ePos: Cardinal; + //sFn: uPSUtils.tbtString; +begin + if (ExError <> eNoError) and Assigned(Sender) and (Length(ExParam) > 0) then begin + if Assigned(ExObject) and (ExObject.ClassType = EScriptRaise) then Exit; + //PSScript := TPSScript(Sender.Id); //@dbg + DExec := TPSDebugExecAccess(Sender as TPSDebugExec); + eRow := DExec.FCurrentRow; + if eRow > 0 then begin + eCol := DExec.FCurrentCol; + ScriptFile := CompactScriptFileName(string(DExec.FCurrentFile), ScriptsFolder); + //if DExec.TranslatePositionEx(ProcNo, Position, ePos, eRow, eCol, sFn) then begin ScriptFile := CompactScriptFileName(string(sFn), ScriptsFolder); + sMessage := TrimRight(string(ExParam)); + sMessage := Format('Message: "%s"; File: "%s"; Pos: (%d, %d)', [sMessage, ScriptFile, eRow, eCol]); + //DoStrWriteLn('ERROR: '+sMessage);{} + dbg('ERROR: '+sMessage); + end; + end; +end; +function MakeMethod(Code, Data: Pointer): TMethod; inline; +begin + Result.Code := Code; + Result.Data := Data; +end; + {$if not Declared(PSDebugExecClass)} // uPSCompomnent.pas + {$ifdef FPC}{$notes off}{$endif} + {$hints off} + type + TPSScriptHack = class(TComponent) + private + FOnGetNotificationVariant: TPSOnGetNotVariant; + FOnSetNotificationVariant: TPSOnSetNotVariant; + FCanAdd: Boolean; + FComp: TPSPascalCompiler; + FCompOptions: TPSCompOptions; + FExec: TPSDebugExec; // !!! Need access to it field !!! + end; + {$ifdef FPC}{$notes on}{$endif} + {$hints on} + {$ifend} +function ExecuteScript(ScriptText: string; ScriptFile: string = ''; + TraceAllExceptions: Boolean = {$IFDEF DEBUG}True{$ELSE}False{$ENDIF}): integer; +var + Compiler: TPSPascalCompiler; + OK: Boolean; + i: integer; + sMessage: string; + Exec: TPSDebugExec; + DExec: TPSDebugExecAccess absolute Exec; + {$if not Declared(PSDebugExecClass)} // uPSCompomnent.pas + ExecNew: TPSDebugExec; + {$ifend} + PSScript: TPSScript; + eRow, eCol: Cardinal; + //ePos: Cardinal; + //sFn: uPSUtils.tbtString; +begin + Result := 1; // == %errorlevel% + + {$if Declared(PSDebugExecClass)} // uPSCompomnent.pas + PSDebugExecClass := TPSDebugExecRaise; // implemented raise + {$ifend} + + PSScript := TPSScript.Create(nil); + try + PSScript.CompilerOptions := [icAllowNoBegin, icAllowUnit, icAllowNoEnd]; // TPSCompOptions = set of (icAllowNoBegin, icAllowUnit, icAllowNoEnd, icBooleanShortCircuit); + PSScript.UsePreProcessor := True; + PSScript.OnCompImport := TPSOnCompImportEvent(MakeMethod(@PSScript_CompImport, PSScript)); + PSScript.OnCompile := TPSEvent(MakeMethod(@PSScript_Compile, PSScript)); + PSScript.OnExecute := TPSEvent(MakeMethod(@PSScript_Execute, PSScript)); + PSScript.OnNeedFile := TPSOnNeedFile(MakeMethod(@PSScript_NeedFile, PSScript)); // for include directive: {$i %includ-file%} + + Compiler := PSScript.Comp; // get an instance of the compiler. + Exec := PSScript.Exec; // get an instance of the executer. + + {$if not Declared(PSDebugExecClass)} // uPSCompomnent.pas + //HACK: emulation of implementation "raise" + if TPSScriptHack(Pointer(PSScript)).FExec = Exec then // Check fild offet equal for TPSScriptHack and TPSScript + begin // replañe "PSScript.FExec:TPSDebugExec" to "...TPSDebugExecRaise" + ExecNew := TPSDebugExecRaise.Create; + TPSScriptHack(Pointer(PSScript)).FExec := ExecNew; + begin // ExecNew.Assign(Exec) : + ExecNew.Id := Exec.Id; + ExecNew.OnRunLine:= Exec.OnRunLine; + ExecNew.OnGetNVariant := Exec.OnGetNVariant; + ExecNew.OnSetNVariant := Exec.OnSetNVariant; + end; + Exec.Free; + Exec := ExecNew; // get an instance of the executer. + ExecNew := nil; + end else begin + dbg('warn: not implemented "raise"'); + end; + //HACK. + {$ifend} + + if ScriptFile <> '' then begin + PSScript.Script.LoadFromFile(ScriptFile); + PSScript.MainFileName := tbtString(ExtractFileName(ScriptFile)); + end else begin + PSScript.Script.Text := ScriptText; + PSScript.MainFileName := tbtString(''); + end; + + StrWriteLn; + StrWriteLn('#rps:> Compilation:'); + OK := PSScript.Compile; // Compile the script. + if not OK then + StrWriteLn('#rps:> Failed compilation:'); + i := PSScript.CompilerMessageCount; + if i > 0 then begin + StrWriteLn('#rps:> Messages:'); + for i := 0 to i -1 do begin + sMessage := string(Compiler.Msg[i].MessageToString); + StrWriteLn('#rps:> '+TrimRight(sMessage)); + end; + end; + StrWriteLn('#rps:> Compilation.'); + StrWriteLn; + + if not OK then // Compile the Pascal script into bytecode. + begin + // You could raise an exception here. + Exit; + end; + + if TraceAllExceptions then + Exec.OnException := @PSExec_OnException; // for traccing all exceptions + + try + OK := PSScript.Execute; // Run the script. + if OK then + Result := 0 // == %errorlevel% + else begin //@dbg: TPSExecAccess(DExec).FExceptionStack.Count + + {if (Exec.ExceptionObject <> nil) and (Exec.ExceptionObject.ClassType = EScriptRaise) then begin + sMessage := string(EScriptRaise(Exec.ExceptionObject).ExParam); + raise EScriptRaise(Exec.ExceptionObject).EClass.Create(sMessage); + end;} + + // + // Calculate script error pos: + // + eRow := DExec.FCurrentRow; + if eRow > 0 then begin + eCol := DExec.FCurrentCol; + ScriptFile := CompactScriptFileName(string(DExec.FCurrentFile), ScriptsFolder); + //if Exec.TranslatePositionEx(Exec.ExceptionProcNo, Exec.ExceptionPos, ePos, eRow, eCol, sFn) then begin ScriptFile := CompactScriptFileName(string(sFn), ScriptsFolder); + sMessage := TrimRight(string(Exec.ExceptionString)); + sMessage := Format('Message: "%s"; File: "%s"; Pos: (%d, %d)', [sMessage, ScriptFile, eRow, eCol]); + DoStrWriteLn('ERROR: '+sMessage);{} + end; + // + // Calculate script error pos. + // + OK := True; + if Exec.ExceptionObject <> nil then begin // PSScript.ExecErrorCode == erException //@dbg: Exception(Exec.ExceptionObject) + Exec.RaiseCurrentException; + end else begin + raise Exception.Create('failed script exec'); + end; + end; + except + on e: Exception do begin + if not OK then begin + eRow := DExec.FCurrentRow; + if eRow > 0 then begin + eCol := DExec.FCurrentCol; + ScriptFile := CompactScriptFileName(string(DExec.FCurrentFile), ScriptsFolder); + //if Exec.TranslatePositionEx(Exec.ExceptionProcNo, Exec.ExceptionPos, ePos, eRow, eCol, sFn) then begin ScriptFile := CompactScriptFileName(string(sFn), ScriptsFolder); + sMessage := TrimRight(e.Message); + sMessage := Format('Message: "%s"; File: "%s"; Pos: (%d, %d)', [sMessage, ScriptFile, eRow, eCol]); + DoStrWriteLn('ERROR: '+sMessage);{} + //e.Messsage := sMessage; + end; + end; + raise; + end; + end; + finally + try + PSScript.Destroy; // TODO: FPC: OpenArray fail (AV). Sample script: "begin format('%s; %s',['2','2']); end." + except + on e: Exception do begin + sMessage := 'Exception(internal): '+Format('Class: %s; Message: %s',[e.ClassName,e.Message]); + dbg(sMessage); + DoStrWriteLn(sMessage); + end; + end; + end; +end; diff --git a/Samples/console_rops/console_rops.lpr b/Samples/console_rops/console_rops.lpr new file mode 100644 index 00000000..0d0e060d --- /dev/null +++ b/Samples/console_rops/console_rops.lpr @@ -0,0 +1,162 @@ +program console_rops; +// Lazarus project +// +// sample run: +// +//> console_rops.exe sample_hello.rops +// +{$mode objfpc}{$H+} +{$R *.res} +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Classes, SysUtils, CustApp, + { you can add units after this } + {$IFDEF MSWINDOWS} + Windows, + {$ENDIF} + uPSDebugger, uPSComponent, uPSUtils, uPSCompiler, uPSRuntime; + +{$i console_rops.inc} + +type + + { TConsoleROPS } + + TConsoleROPS = class(TCustomApplication) + protected + ErrorLevel: integer; + + procedure DoRun; override; + public + constructor Create(TheOwner: TComponent); override; + destructor Destroy; override; + procedure WriteHelp; virtual; + end; + +{ TConsoleROPS } + +procedure TConsoleROPS.DoRun; +const + Script : string = 'var s: string; begin s := ''Hello script :)''; writeln(S); end.'; +var + ScriptFile: string; +begin + { add your program here } + + ErrorLevel := 1; + + // + // parse params + // + if (ParamCount>0) then begin + // quick check parameters + if SameText(ExtractFileExt(ParamStr(1)),'.rops') then begin + ScriptFile := ParamStr(1); + end else begin + WriteHelp(); + if HasOption('h', 'help') then begin + ErrorLevel := 0; + end + else + ErrorLevel := 2; + Terminate; + Exit; + end; + end else begin + ScriptFile := ExtractFilePath(ParamStr(0)) + PathDelim + 'sample_default.rops'; + if not FileExists(ScriptFile) then + ScriptFile := ''; + end; + if ScriptFile <> '' then begin + ScriptsFolder := ExtractFilePath(ScriptFile); + if ScriptsFolder = '' then + ScriptsFolder := GetCurrentDir(); + end else begin + //--ScriptsFolder := ExtractFilePath(ParamStr(0)); + ScriptsFolder := GetCurrentDir(); + end; + // + // go: ... + // + ErrorLevel := 1; + DoStrWriteLn; + + {$IFDEF CPUX64} + DoStrWriteLn('# CPUX64'); + {$ELSE} + {$IFDEF CPU64} + DoStrWriteLn('# CPU64'); + {$ELSE} + {$IFDEF 32BIT} + DoStrWriteLn('# 32BIT'); + {$ELSE} + {$IFDEF WIN32} + DoStrWriteLn('# WIN32'); + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} + + DoStrWriteLn('Demo start: file: "' + ExtractFileName(ScriptFile) + '"' ); + DoStrWriteLn('-----------'); + try + + ErrorLevel := ExecuteScript(Script, ScriptFile); + + DoStrWriteLn('-----------'); + + if ErrorLevel <> 0 + then DoStrWriteLn('Demo failed.') + else DoStrWriteLn('Demo finish.'); + except + on e: Exception do + begin + DoStrWriteLn; + DoStrWriteLn('Exception: '+Format('Class: %s; Message: %s',[e.ClassName,e.Message])); + end; + end; + DoStrWriteLn; +// if ErrorLevel <> 0 then +// Halt(ErrorLevel); + + // stop program loop + Terminate; +end; + +constructor TConsoleROPS.Create(TheOwner: TComponent); +begin + inherited Create(TheOwner); + StopOnException:=True; +end; + +destructor TConsoleROPS.Destroy; +begin + inherited Destroy; +end; + +procedure TConsoleROPS.WriteHelp; +begin + { add your help code here } + //writeln('Usage: ', ExeName, ' -h'); + DoStrWriteLn(''); + DoStrWriteLn('Usage as: console_rops.exe *.rops'); + DoStrWriteLn(''); +end; + +var + Application: TConsoleROPS; + +var + ErrorLevel: integer; +begin + Application:=TConsoleROPS.Create(nil); + Application.Title:='Console ROPS'; + Application.Run; + ErrorLevel := Application.ErrorLevel; + writeln('# errorlevel == '+inttostr(ErrorLevel)); + Application.Free; + if ErrorLevel <> 0 then + Halt(ErrorLevel); +end. diff --git a/Samples/console_rops/console_rops.res b/Samples/console_rops/console_rops.res new file mode 100644 index 0000000000000000000000000000000000000000..f7255606df788df3e38363a0ece10b78578c13b9 GIT binary patch literal 1004 zcmb7@Jxo(k6vuBv!e}};Fm_~gV>S!~Lm>#oO8IC(0<=ho5n~!w76%g-2S*1OF`DQk zai|1>G!P)RiIDQq($YY`_$ct`pZ|NOyjQvqZ_l~!-1mO}d(S!VRVk$$bU>Wpo$-*X zM|9wUa;nFwS+&v|RU5Cj!*0Kg^s9|Oxl^Y`YV@@}JNN{sq1$w*Oc@Fe}!uBuj*4{JJ);;KS z`&zpCpSXIPJ3LM8&ym^DCFuxK8#oZj5@Nr}KkXat^!jw@RQEG5V%kfme` z=_pd0I9Nk`1$#^6Nm9c3#iuXic?!-llTAtt$J@ZH0&OrEs}Z~tcGe05H~TuVM7e9!1>lV>e=_P^Gw{ZG@v_XggW zJZmA(-ugfP;CtB$e@98fRgq1@d6v9)JlJRO=KG>Vc$Y6g-jI|#Kz?9iijw}Zw>*W3 yu@;sueAmEB;SEU%+NI>fWN7?8KQ2dk3iIKMW`K^p1mQA_<*f-~sn z5-@+3(A6`wG&FivkR;~kf(Sns)TN`LVg9Q)Bw!=jP89TvZ}dGl0MLLB0FeK#xQ>On zjfJV6hP8#I4b{JDpwia0v9z`@{*-hWJwgND(#*cfP7{iA=F>y!kosnY2PPO;;fGCb zIK8A{JmO0ciILNx%npMgdcZdmvg-FNDw1=OxsP_c20JT42n$nuWMz+X z$9-HXjlmpA@OxHs$7Kf(u@%x7Efx&F`04rzc_HKAjS0TbX8`trl0+LX#7+wlHyR@j zVj8f{|3J=P?wdQ#m@{+cMF`_;Au(BV|E|u^y<9YXhU5EH5rGy1!Gt!1Q&O&?SrW2C z0$1Akjq&NM*2UJakMriy0e^|TYxTkj+#%NiCe}P>apmn*t8}%B$DUjBhOxw#wklX- zQzAF02mvzwZ=YnSGST6CYy>J_Ll=Ykz{wEosDJp@dCNVts~t~AazZV;+tW|wtXpr0 zG*fWePDiVp*t?t5W>PrAVLrELG*QfC0!cqO$K#tALBG3%zQ59!x{B`RMZde;r@o@? z;zz%`ijK9^@X~5Q(sBVfrFxRZ;!VmlngLU5qJ))xZjJb$<-)>JLt{r`j!ypfl6E1|nJqL1A7+DiIT=x-E;CaTE_i}VWiRQIRKDDXqnx~h z$#|pZ9%eXsrvL?o7fF+gI!=_s0e}!;xWpHaZ($r(D%(fQp~=6ZAtoJFpv;=VEQzCU zbrmM?earvBfdYMRG?Bo1T^KBMt2RV30wI&KIfa2+1k+phh$= z(Znj{%wyzAm}(#j16;Lq$V<{#Hao~8)+l;JkeMb*8SMP<55PFn?2+2Si8{ogmDwEU zpb9habNl{wetR%cDTqeuK&@TIFk&AVcOa`|IS>fLHaIfV-|4pq`gScvruT_hr+#izclG4ZVOKa5#KR*H9HLS zDww?(&>DKp-9ANs!(xfdP4Pa+UK8r1(^1#2U<$QR+h5mFW+WogkObePi9#}RLNK63 z9w7y3kz9T7u>M2@14Y0_2x~=URwtY6fQQv%32zJDC_=r#$M)i52AUU_UE(eB7cDA+ zOPa;3HVLP-mT5fw5^!0{AXrpbBd7UI`*iz#SWGeUkD^j;0B7;HxJi*y0{^=hgsR)DnTA325xsOAM z@f|v|{R~b{kuIFBLj{*812K6&_`}ztGRSciU2bL=^isLnV`zKjyRRUnX8@51Xj@Xp zox{%B{7+8gnV9 zN>IxUK*whf4Xll%DrNSrEm{;UwaJwaz{j=T7JOlP`-#IIf4>4F(s8!a>b+L(B%g9j zNjN@|%0R_xfCqYNHk-)z?!BxTJr(l^4T2!Do(|Zy-gmqzBH9B4_ET3hVmj9pOR5o? zqzr2&Z&Vr9&)wISJ%QGB%w7@cT%m{q3&BO~)v3}h0^R;ix7yBu&4G&rolyUdn4qeeM&;ZVjJOP#B~SZFx0ahYU^<+n^- zLa20zqd}zzVT>4X-Qtr(LDq_c8zHKbLxnd|HH@s?NIE!?mT=1H)#gK>_8l?Nz|5%S z5^<^l1c90E5XO882M$>{AGk3d1QBZyl&|>&!8e9~4xEBR?S|z}+QaN7|B) zw>cW-eh?_$^K?ZX$&(=MqW^#@{<1&R6G(c=TlWX9mo=cyo(DH0us;@awpB0zN!~n3 zm6krF20vb9&}U|u7M)DN5CRUiIy|VTj&Yn^F`uvTN9z^PYYnAVc?h98vFWQT&3ACS zi=DIF2E?4jyw+{!eVK5yTB*YF(VZ}jB|bp}2oym#+2===+DSP?AhTGm%@n|-nG9oJ z?=zV#{H`69fhX^`e42L*s`^@LKOLfSCr(}M26oF68iMa)8b^B@Z>`ndDClIswV<2es~p*xL^{|xCZ+ZO*qAhY?f?-jH) z+QeSP22EeoTZ#P(0_k{`co0bt1}*s|bbS!zrB@5!4m7akA$wk2H34uf@S!be9O=Zo zT=;1(1}enG4?!tOv4^h{Ct;wKeiUrlUdbii`C5_Bz|PY+wOTa$Dao1TRMYUbEid(+ z*nTGCPbA&ZWg^rG2_+4sCQ~I+t@wgK(%EKcn}HQ45xX(xh^1pEeq_P*xBgoX`g^59 zyf=B^<|*9&Tz_2~lW`>#i%}Y6_mZ*u77S`I*PvBUQp7K6Kta84dnG)j4EtWi5y?ec zUw_A(Jx*aESDSokG+i*$#dZE;ploon21f(An+R!qbD1Yzioxk}TSS?A-u3oNc%fd3 zTrZv4WZK5D@k=aj%8&*!y5mn26Z1W{zPRm&9uft1O0LYS%OnVkD-!aH+(in4!o^%7 zNz?&8B4ypXfv^xlBFfETr`ebJ0*)+buw3eJ-Zt?R?j-_W(7Iw-z{?aTjH6#s-xaWQ%Ouo((tk^-M}M5@h>-i^Gl@bJ=37}5#m^k0 zWZdPjer25ki5*V(dIGGZh*oDNA5lJ$WED{s0WlP>vY;l~hPIl3u|VF&iL0m!oYu`z z>`LUnK*!>L@mA^HJx;--%y(KDeY7V04M7@!3+*n+pl1ldn0pEi{!mohOL`tv=lv!& zamtUAWUCeWjq8j-mJ3%8@b5-q7m(ZsTlkXca3{QQU-+rdB3S(D&?SrqlMGlKDc|UR z3(t^XMx+2KVYCXvw%JvfWOE`GnsF6)+l2T7gFxAF$| zw!rX%1*{B&I1MytNa(tp`%1!ym~3BNGXr~m(syVM;v^R@U(#jZNf?#}*jYk$5pnPe z*KlIcj)cRS2nh8K>L5wUF?;bQl+7Q*u))W%~eC3$Po1LN2>UC zD9Be#UZ+mhexB#IJD0{zbbIB>_G|U_JXG$6Pq5-$n^&kl||t$P1XQarh4g{cakdWf`9 zeVW`XtaH=A$W;wM5sjT%w3?wvYvZ^W2KXSOcNEv&Fp@q1ENER|CdRQCu>$zW{95@O zT}^Du&m@G7d(Oj5X?{T@rlRo`Dqz8yx|Z4OEF-`jj$`*TIb4jGm%%_eT^)D>3af!= z9r;Jq9q)Tf@O=xK*sT|{TH#dPsdGBvZ_wcO$vSd(B?C!`7aWE*R?s>jRSU9U9?DaiueD6di~K+fTI|BO*uklM z^ZFd-?At!)PP2J<%0-a$uBgLWgN9w3AQg1-mEG<}mi;NSA{S_pN4`yEf?dhUTwrbg z(rWV)UjYCWkw1r?NdMq#M-5sUD%xkkXKj?7Xhhl%E)+-rAm$_KZl==kCjmA zK1QGW%DcrQJn(lGE9|(myzWE5`0AcSpJW9PAUjmFNA`?R^Qz|cXUPm*={zolo4iLq z)io+3Frsrh!|uD<%qM<4pt?OV#$ghKkvn-cFp% zLlgKW>5{Q3C?J395;a3FS-X0^Nj;uQqo5ToFSvBcG9r2?BVa0RO3veC2;xglJbZgO}^1TRsYPibEVCCIf z&$gu2G-Y%{T`7u;0t4_>b8!7?Ficc@;6|Y-R>F6}3Ma$c^>rAG8FofMHGF3?90`c@ zCIii_Jo`U|dB4mEr&hxWX4RJAJ8$^j`Zc-@6T(58FM5+o0M?yk$Wad z-uu)zf9VOOBG61W>_UPa?Ea*=dOp?s45bL z=Idb6pzMO6%q`Pmi4R@wm~PQ=I;mn9y4SRm93fodnQ#?(NpHsq3h+=n4=I^e!L~42 zw;Aiq57_tfI8m(h_va*LYLf*Hy9>))Bd*&-lm@y^x0N*p*1peo>>z9o0+dK8yYuyi z^L?rk#ue)4O@z2Zqeg8Gv{Bz9Yf|!bl2;{dI+5|6z77e*rYp_Hx&g5J7=&{sqyx&h zn?f2|-@DQd3EOJ57BSX1QxZ<;R$aOkdxlyffUBbk*BSYSCXPn;m6jybVPp;ldYMw# z%`lt4>|mgc2NACJM_{xUL*64;_G`JraWGyoOoeFZN3s!dzB6n{SdU2#D36ArF2y9_ zp=vV{DC25}(2xmS#k+tHTQanqEI$Ul2Cw9pphv@7unuG6W4~ffr~}HODv!XYZxE>B zYXGUNs>f~8c(1DsF|2TBSPEzXJ{OMdeXHr7fR~JOLu3LvXPqwK-C*s2S(g*``dUhy z?cOJ>)L94l&D9IP;Bn!0CAv0@ zDHL!Fqd4UZ5TB5xin2P(3(F(RjoRwrl`zPqQ6f8Ws`b^{Lh;MhFxTh4b*ZRto?b88 zh?Ps+ooDM%J)CHA2ubcGC#TDGVmfj7ocz7+7TN|%AFJkKvfj*`x}>O0y?K(W72A^E zas3=H_^Neu+_p$xj2MofLl#wSYRY%u8X&E~C&W(4ea6A(GqIbhxzc!qIP9erGi1se z@ExIVZC~N4bK0YE0kOQ&3a0ffH)z~)wYozE8mOhAnqt*UHfY*ey3*bF46d9Kuhx5D z*bZAzITZVP4^hAQgF}l8C-9RV(VXS^Z4PFr-ldV$y;dZo6Arq-H=3Kk(jbWmh|4>b zLNhF1_ST@YSWAb&s)RbGc6C(b0)vD;Qad2nntlPH&b$P&of)3r%Aif3f`jZRcL`*- z7Oz(2=BdKsgi=Bh(Bf&Kn_sy`bE17;`Ze9j42%hz|J*(>$pW5){)K5pr6+5!pspte z%t{}#P1BOvF2yT*Iy4+PA|t=B_ik143N}tTCc7Qb6XLFCA;)d3vN?YAviXSvZ&cN6 zcqPfKU7S2<6?hXHHmXjfiXEsJtLq2#cjQF3}jIFuq@~(<*S1 zJ)i(ZQ>n^lQE#t@u?Jy)ah@NQ07!;EXJxV)w_m;Sy>Pily2~ZFi6>0Pu}@1gXnM!N zg4(XW{4!^X(UO4mz0z}B59)9JRRxgl#jc027tRhvM{Em1m zBMNv5lGc|W{fYdyr|jEr)|4^!Ae?0zMk-mgU~}{C&p0@U-`_6Wi{Bn6ve_`jR(S`p zxx1D$Af#Bf+npb;)xJ4v-o2r$Oxa<(hq&1TN&}zL@*P9gUA%m&Ct%NQ!O7T;am zg1@|~Lk615I(^w;q4mLk@dwy4$OkI;yWsdbxKfO9jjOW&DU8~jQr{T@saAQ*$nbp0 zXkXa10?$g}_oh^AY=|&NXaoKqtGiiQ6bh)shR~C3?9@BIdr#hoqUhmD7Ta1TxM`KZ ze{K}Chdk&oz_APZxIw59TNtM|*u>_7bFACyUcwg%;$E;KI?}aEJ}metPt{siJyQ>b zHHB^1$&s>C==-In(F+K%;j$gh&^&nJmCK}Tjdxr&V~y(&ca?&bidjmiyu=S2 z`%%fb;oVz5bbeEu80)qj2VJqQOyH28csCXc-qqKS8sR2B={wc5Gbu}cmxs<|1ciuxn-j!ga80`2mt`H|Hbg)F@)X@AEkl6YaVF=xxakhVvvF>06as9 zYZatM1;jVqxd%Q{V=YsxunG~;PEHfP%Ojc^d*KqhEcp7z)*O1q!%S5V<&5I2>;k02E-> zCw4@uG3+9wX#ge3f{;cKDZ4l>c^l5CIGK|9mYKw>y=|XPjtK15hRwvA2IM}=;z|lK z`maOO>7$8NVp(X@;NfLvkqMaC98u1|)S?4xR_79N`lfk$G9v7SeUhhjtTHhXbc{u- z(1QKiaBJ5+H>r7vKb)dIjXQ-R@D0@xS5%ymgP)tEy zAAM%IPE9WQ{KArp5Njgh(z}+ueU?H3vp#G>Im9=ozDEJeiz}~%3`3LPVEG7UkSCY; zZDpD9XALOOAQ)=C8o@)ovJ}0Y^IX;HZ%DT!5T<#>gZh>Rp^StDaqJ9)3@tSBc!ib2 z(HL~!3rX|hZN%I%fmnN=7XQZfvqOyuXgCOAa zl-jBGougGLVw=ebI8L#vOX--KTpL)Fwu>YIX+WqX6Ozyoda!t>(9F_OIyRP%+a zVCdKTTHpfWmSllv?+*ITXMO84`jB zeN|e8L&w{jsP!vofYNnYbtijVslX;?k%=4LX;2cdWNr;O(44tzQXI1dLsp~;{JlQ! zqz(3sHy0X*bN*Rxg5{(;3X*btCWI1@y^-5Dsr4ME4?eqojM`an->s6iB69Z6&qxy0 zExBPir`eq$6Rpp{yf2EE#wx;Tplf`(enSIcj zx;d(i&+}AO}`EK5<+)Q%L7xLPR`Gs^T-4PRA z1>>@PHN*u8|MgeL7V!@&Oo)lD!bh}bU5Nr2M>M27AXoc~+;!QB1oY@DMd4IN!851! z;Z$&0d2aSldc#*)v)>%=u$B1~P{9(ct6ZdqbnQJk^Fb6L8?cXpWNPz?&Wlvq_?qg? zIV~UxT2xu`QY|=T6>aPb5I-*T;`Z&9%<>5?G@4Re1-87j={$2N{*5tXNkjV={ zpVg@NcA{VsN3+5N@KK`2%`?Z_Wk}ky8dL&*gtMLFjA?(;CjEAI!iVW@B(|O(Ot?b( zen2dpWM;mF(*o52&3>S~#nq?0-tLD+dtV@bV-2#Ue$RG}X|D~ds86*I8=qs)%xMv? z8%J-&P7tsvnu-Szo|kCBM-CR{my7tBf;+De-iY;w`W1qV`UuQW#qH&W_a`|6L0 zw4e)TWAbETWq07@8eMZwp+=UjV}BNf%^A2cB{xtig~|@8A;DgJNoE3?O#l(2N@~2_ ziR(1Y1(|s3P#wQTuaWMib|)4XwT*xf9#y^KK*oUo=RItaJdQNtD{E+2o0;Rd4}PZn zunB9dLqs^#gxcPqGbmPv+NUc`&4)nz1Fjqdj_*-6YcW4{@6x!)Om3eRQEO6tN}@Hu z%Ef{9ud;&z%?KBRpFy62hk4ihBnld{ zPBBihf8!#0TTXVdMXlybc5`lo)d|GQ3$f3-O*IiPMQ2~fAyN^_ue~lB)Gt%V&UbhH zJfc(hhGPrHuXkp?%BfuI)8g7*e4aZkCVkJjn6_Q$)-f}#Xy90SVyrVnX${`!UGfRDPLvfl zv2j;F4cqM$rR|{3NT90NcqWSysN!DtHpSPa)^$GXNB#9?s_lGB%lwui={@k@WQ+e0 z%L9MiCxZumh~ppTum2ZhYprMVDTZ78y)<&?yCT}*)`r&B;o+$M4nH(A8d*@~w|7;z zK+uTVV`wWoE1D}SOIx^Ef=C}3U=0b3eGs%od}Y%=eQLc!B01XHys$nw7^RA~bRMWD zKD=wPIjk*FFw8~s6fAoAW8R7TD{;8e#PHXH8zXI8A;X%!H`Zz9pR=*C1wd8v6B(^J`{o&54g^=X~|A_&fQ@J${ zwrEx0X{FBvy6D{(Ybws*{84DT+zCm^j>j3N%LIfZpQO`ufoh#}H%qTj@~IV5CvK(M zHY>XZyKPWRH!Q&3Vl}^NbsRG|XPG zLPg5)N#$XW#x@Q;$E=VY+&PmylN7184c0nEFexX)`Yc4}%R%*n#*fFw@}fkW8KjG} zj$e=V1e|sWG4&mKcRziQZ!)>eS)T6Y{(fOfz4(oEk<)tiXwQ%1bSh@@h6?6bA#Y}? z=xC@^4j1Qj@|Kn3p^J2;D+?Q6s=1`6>*A%FsI${T(6J)ztbJL7$| zP})W<^u<@dZ#I;%XeG-RtJXa1t$8|tE<%#;Be?Nso7q8GCUy&r**`8TC>moMIxyjm z_m#jc#i_*J6#A|KlYbG8RO0ONOfi_)nLsK@O*@8oYF7Y2?9QEj*C6ovs zRx=z=<6I6u%$Qt~0ss$#zJINw_;Z!SW8t5YNe^HAl}R$6p+UamHacv{6#0PjhNqq! z4-sCutkM&*UL-a$8EuC$=uOvjPY&m_`(D&Jw2gS=M~u%IvutK&a?z(BuUYLS5t}@2 zb0i?$At;q=t+A-LNa8Qf0t+*M(4cgEXYu!PFPL&dddtg&uHu{Wtvs}ZnKt1@J@H}pUe0ljdQr=fn zD(QNDZc~Bydv+goZhaWb41p;-JHDFmq+-&9&R4+>lilX0WCwcs})Fbq|dJvgS zY6n-}VWAJoXH;kQ=JFMaurc3(aur{S>XbhsnNUp;0;>=5)`aYBC)4~#zc#_xp|DeL zYx0UnQ(bq)sM(slG3zLcQLY%{Re5(Hl@2osDb_YMv$<&C`J@8wq0SDashQ3qT@09> zqCUQ3yXzN@hCm=}+=2u8+9E@`8yS9$P7FB$5NxAH36-ZXYaeHaj;V)T>9DwQ&J4cZ zIm!yXni%utk%>WV_e3=vWuV&)EHgCbtA zZ7YOO6p+0EOYqczMk8Pl4PF@n%+Ns-AiMetqSsQSfQ7Cd32f%vRtQ!dv1 zf$*+T`qnhy5t*DmqnzOkn7Bv>tt_jtKzEj`bb~oRYywZd7~oybG#>%4lOfZ5{7g8C zyyQYpzUtdfyBY9w&wCh-rD~0@Ayq+HAnlUU*LS>pr8)UQr{bH6%PiUM!ryDn{8E&L zboH5{;2ObF)3jk&q%4@QxrWCGXy1d#nV(L-&7cURV%c;uj6F9(x^@@nk^|zbmdQ&-jhE7v(K>vf;yu>1IuG(s04_LohF^| zYW8CWex!!kc!v_DyyE>$$($u1HC6=|ZfCT0JKY3UaRD@nP$Fe7k+zJ}?Bh19V8Zn6 zcD^LGlC^)0hcjzz@rMSySjk&Pv72U@$r9OJA`=2iTb&^nCz%F>4~e5agH!AD1P9;m zFHZIk*V~IvxtCptU4=7}omlmcHc_M#`n-CEDpH30vDWXr9Fygcx(A!Ukpcv$TV$u- z0&fdYA5TOO^S2QrECbS{>HL)lS%HTW}GN%QLemRx?vRDFL3yJ9FxNz z4Bx@B$-Fgos~7l7+hhvvWi>>;$ums-B4cLUhI zdlx!7dW-y-x&zvSK}kjcXVwxpE-HHB>&M$#qaC_ZNp!;m2I(>*+S+x+j@nIR%MA&gJ;4i>giKkBc8yVKbn&r_QcLWbl@Y-i z{V75)pdv~yX_e(&fj?hpLQO|XvwCBzha|@#i`XXvSz?1wpxM~OHn(aGJW+?H5DFyet-N;Cij_He z9fI{SLBk*IOg2F-fZ<`LBA0B683dixY&2iwG76@McXjsO?Tu?1!**rO{OAQlzwVTj zx=3tOy)Yl)!3@j^Zo2_I5hx_UB*ISgCQ|$Q^nnwb9tiQxf5M56>5tjR^oN^9{vRs{ z9K4aCs^)prUozeH5dfwI~1LC%0eLbDtEnkTW9LTxiw9*of~} z$83!uHJ?=^K-Z`)eXH z@IDw4Nl#70Atw%Z8eeAd4fpK1EBXSB;K1F{+$4LH8YIi( zauDny&MtA<$}qW(8i>CDMd?a`)}U)8wX?a!K8WqHff9-i^m^+phM#zrNG(Y)?#4^# zgFu(y!6sC~FbvBAWJhfKjZ(6lr?2lz5#Gfx*|$)w@>g{E{OauStbtud(%CV=R;(vQ zwxq&yZaF8Iu)bVx>^Edm^o4fMy$H1${No>ToALCe3G4|a6A(x;B4Dp%EUA3q+!W=L zrOuKe(*#znK4VIbp&RlG%nK>8G;SFzUy!gu3}&wczdDm|A;Qq4rlEyW=|F^vC@Uuf zY7dHh6-sT{EIH_jD~-aEutX!qeJH=WyGnHEYx8oT_E4Y7t_DTy1!iMB3{p3~BpQnY|S;?WMXR!4S9zHL;d` z{;d7`!LQw^80AOZt;_uFpIaQZ%0MFEf*Tt#TJD%A1W_Ytr)5D|^P!MvWX?6;SBTKT zy$9|8^flzH{BC# z7U!?pxHjvrf8cu=^i8vZ)5MQ5h(dQ^h}&o*&n;|zYMAc`w6|D1$fTOkcuaZZ7~JhP zb*B;;Xfch<IpR#SUVj90z4TUJyX#mJnPj6tvU zLXx10=)zU>710Gteo~5pxcQo7?w6TAKI!k zSYkCnsB9)tt~|TLnyCZaFfs6<7u#16IQco{q0X10T@kYR_H|*aU7U+0Y219%{;LYz zV#RQj8NKfv#93zv?Hqbul_D_$#DXS4xFkjuH*W%}D3?R`ja7!s_+k^pV8*wL0tzCc z8Vk>40O*7P9=V*P-RCtQ%|Vz?8~lU3f?g7ts}~d_(7$Xz%8k+XUe95Z>LuJG6}U78a{$_<$3>s`vh6S~$KqXd=2FS>^F zP&AX^3>PS&Dp2a}@5%9Opw#;^1o>)~4~(E+pC{AQC$?)zVifz()#5?y_*uOuA6^f8 z`#A(-79Sfhq_7jxBTLr<7yD9rhrQ3&JQ((0>Pqw>ujW7y*mCN(VC?7u3S^k!X$cKY z+Kc$+?v{(grdMI<3DGoY2do07x2tHXi~34bC2OJrUfWCvpK^9z%3*Qy<}F_mRs)YD z@u?tAL?3O?wLy9AYen@7c2LxBT(1^jsvJb=^iBjJMq9+{fGm(dtWCWo<;QT!YqAD* zAtz^fiBG`)62B%O?@e2g0>ex1QP;sK(f6QUaQGe@8u`(UaI4CZxc%hd%zm}enbSC09b=CPM7-KfdkcZML%ux1M`i)E6mLPgR1bsT|N# z+=KkhnX(U@`8=8NpK#`Xvl#!)V*J}I#?e1Ec)a*?5N4|7tYvLy^H&N3069<$0rkad_uSs7V9hYUyNJAfoH(>r3JNXbi8Y%2Cb_xX12?zXl;-p0;M*|-J^1lPZY*ZH6a~l4{%%a=(6WqISabO$5x0}Y`}$i z_>^LxDh)j$%~_CqS<%$PLaxNEz*U(Opn9ahz^m{rCY8qeGSuW^n9qHjC`;;l~t%V8+Qij@k`-g=!d^Fi>g>-i&NkJ81C;a?Pfa zuG-fzHe#biI!Y$XSGF!BCUxISNQ5hb@f|KSXBfo8je>Y7S`F!OWXWf@l!Hnb3YjoC z%Qk;@DOluoo0t^)gq=X$gqzO-7^PEfznW%~j{1TXff!Pr<;4-}cb0TMV>?1JF1+4f z#iCt`@2tsPVUyuIDr|&`sa`)a<`H?Sk9!284uHGEdCS>A$t6V@?vKsa;Mw?@tYmoI z1W3)>ZMou<_hMGnWr5n_{6mns3)5n2F6wff2`{NSo!~S#!zfq(9==3$6^}owzC50b z1U*|5yp?Vt<R_wKd@4@yuoIz&{sovUR3w4qCqqsCPNX&20f7Yz$I zR|f=UG_b?B*k6;jxe2m$J>cRHJZlzbGG;KDxEEcV_1fnR>sM`d(eGw1QLfmlzS$F4 zqShRsaOo_sxR3oEl!YVkj*}~qtc&CHBb<@an10#Ys40+c^JGuDs z#ihBlJ6vklt*xaE8#T3qg9Fu{MJOL`?^G7n2GlR1pL!1fARGTP4ZM1QcuoW6 zdJdLaHac3Se^Cb{;MK!9&xwHM-=6am75r7zf63s#Wbprp3?7@NqIUS%%mW#;JPdyR zKQv97@pu)BWE$kIMdE#S+=XP%T3_Mr0!F23(|L4Ck%vhdGKje`n5l0}Y8U$k=}UE} zRHIi?q;OMQDK_r+Hl``v%Vvle%z;+o-D6)M;*4++M<8S7$L2mqzyY5g&CfE&OmA1O zb_o5@MT;TKYL+6A58SjsvH3xPJZXcx+Rox*<)5?R$NG6Y?l8i>qXbF0y>^~ z0~}aWRIiOKScM`<^2=6l4EiJlT1JqHgksds&LqU)R-usMQYfU^zN2VrbPtK-l=8XU za`huZ-IcQ)*gR*We!8=vqZc*}VZ-R=Y1PW3XP_}`=Ojb%2Cr8?P?9pc3quL!9NQR& zbI$93U4}(Tk44?|>VWb?2u>Bzru&Q{4LmIY{1P1Xq&o98%y381AuJ8lcTXIA3KEq_ z$oUCYM(f#hFBe_ZxvJGmv$b>KYL-mfG@hyw_Eu7MUOAEUcCrQ#fVd8A{JS2%@-mq9 zkLe6R?-D)R!uG>#l7(8nvc;yxmVNK>EH0YOC$ra)dzde%&e{Z5D;SAE-x`xt*b(!p zsc8^pw|aCtWL=Ge0%|GM8fm>1oZaoO%z8 zSW^e8jsvC7AVSLf))ukV1iAINF=qn@6`iFuPY$@b8Z?#4Yf;FXbwy$O1IniTDzvzV=RXbb0f`x&tqJlfS}o9zuy=S_Q$aZ>{+0 zyYH32IabW?byL$Od*b^*VZ?)O591SG>k6Z>+F7M`ms-WaJ8=j%$b|1mWtC(k$ew$Zu(!ibz;D@{od8)pHh?+~p@wu0Lu5B_XnAt0R$8(w*!mA`)fg;0RwekPQs z#raP)+d5eqT9`j$lYfR4RR3U;KTr6HO8)px!;y*Mzg+TPF8P1NCI1X8{?`rjzoEr{ zLyP}EhZcAbB(Sc^ulacMe?0Jif9L%@13U&6mPV!)wx$*aMmkhF7G~5oMz(s!77uS8 z0}LQwZot2L=m^0B(BljK5Am;n0~&z)uTMY#G(Z?uCf8BM2#^=c+wkY|d9A-bsN{LA zPpbU6Am@4IQk8HFa+xDQPx1-mdF8)8+~j%XVhR}!GFZ%rk{9*t5bKuC2ylyHFfUrn^06)p+TK~G${3qat{dxZh@WaOQ=fIAtB>|7X zvgIBB()da9zkz?ZXYdL5u@QE{{tW!*4#MXkcAb`2st+Jf^4Deq3HWuN;SSi05dQ3= z<}dJU2cOI5*uSpIe2)F~A#w2^Vn57oJl7ks&)81w0b4cA=wH@Yt z@P5L6T$=YB0CSV<_ED)P`8&7%y4vpv;K8c^;a>rMGU{Jz|DMBo=o!X8`tvhTD7eCd zw=2su&N}#==Ce?&yK`h-$sAb^$GMz{%uT1z^^k>&p{)p|L>sx@Zf0y zDA02QKN^m``=M3?y`+hgm@w|2zx}R(R9m?CA zk|Ny)!#&AgQ6K^T3}Yw&PbiOlpYz|K{N%Dfp&vt<=Q?5>Mf7Mrpd%~~8a-acll5|or&S2TLaK= z|8={2l7FlGyUgVi=wqWnWceBNuYmQZ-aprxrt@ghC;2{wq^AFfR69v!PQC3#y=40c1 zlE3rsKRYhf-yQb>=_YcQDNhvX~he_iHLVox| NdPvRMJk$&T{2vQ5gP;Ha literal 0 HcmV?d00001 diff --git a/Samples/console_rops/make_d2007.bat b/Samples/console_rops/make_d2007.bat new file mode 100644 index 00000000..a18e3e97 --- /dev/null +++ b/Samples/console_rops/make_d2007.bat @@ -0,0 +1 @@ +@call make_prj.cmd 11 console_rops.dpr \ No newline at end of file diff --git a/Samples/console_rops/make_dx10.1_win32.bat b/Samples/console_rops/make_dx10.1_win32.bat new file mode 100644 index 00000000..93c67680 --- /dev/null +++ b/Samples/console_rops/make_dx10.1_win32.bat @@ -0,0 +1 @@ +@call make_prj.cmd 24w32 console_rops.dpr \ No newline at end of file diff --git a/Samples/console_rops/make_dx10.1_win64.bat b/Samples/console_rops/make_dx10.1_win64.bat new file mode 100644 index 00000000..66d59568 --- /dev/null +++ b/Samples/console_rops/make_dx10.1_win64.bat @@ -0,0 +1 @@ +@call make_prj.cmd 24w64 console_rops.dpr \ No newline at end of file diff --git a/Samples/console_rops/make_prj.cmd b/Samples/console_rops/make_prj.cmd new file mode 100644 index 00000000..1162f699 --- /dev/null +++ b/Samples/console_rops/make_prj.cmd @@ -0,0 +1,1738 @@ +@rem NB: FOR WINDOWS NT ONLY +@rem @setlocal ENABLEEXTENSIONS + +@set xErrorTimeout=1 + +@set xLang= +@for /F "tokens=1,2,3,4*" %%i in ('chcp') do @if "%%l"=="866" set xLang=ru +@if "%xLang%"=="" for /F "tokens=1,2,3,4*" %%i in ('chcp') do @if "%%l"=="1251" set xLang=ru +@if "%xLang%"=="" set xLang=en + +@set make_prj_ver=2017.0306.1527 + +@rem # +@rem # make_prj Version 2017.0306.1527 +@rem # ================================ +@rem # Description(EN): +@rem # ================================ +@rem # Compilation: Delphi/C++Builder" projects/modules/packages for other platforms (win32,win64,android,osx,iox). +@rem # For show help run without parameters. +@rem # +@rem # Description(RU): +@rem # Ž¯¨á ­¨¥ +@rem # ================================ +@rem # Š®¬¯¨«ïæ¨ï: Delphi/C++Builder/Kylix" pas ¬®¤ã«¥©/¯à®¥ªâ®¢ ¤«ï à §«¨ç­ëå ¯« âä®à¬ (win32,win64,android,osx,iox). +@rem # ‡ ¯ãáâ¨â¥ ¡¥§ ¯ à ¬¥â஢ ¤«ï á¯à ¢ª¨. +@rem # + +@if "%IGNOREERRORLEVEL%"=="" @( + @set IGNOREERRORLEVEL=0 +) else @( + @set IGNOREERRORLEVEL=1 +) + +@rem params parsing: + +@if "%1"=="" goto L_HELP + +@if "%1" == "/C" goto L_CLEAN +@if "%1" == "/c" goto L_CLEAN +@if "%1" == "/CA" goto L_CLEAN +@if "%1" == "/ca" goto L_CLEAN +@goto L_CLEAR_SKIP + +:L_CLEAN +@del dcc*.log >nul 2>nul +@del /Q *.tds *.lsp *.ejf *.drc *.vsr *.~* >nul 2>nul +@del *.bpi >nul 2>nul +@del /Q *.map *.jdbg *.pdb *.rsm >nul 2>nul +@del /Q *.dcp *.dcpil *.dcu *.dpu *.dcuil *.lib *.bpi *.obj *.o *.a >nul 2>nul +@rem @del /Q *.bpl *.dpl >nul 2>nul +@rem @del /Q *.dylib *.dll >nul 2>nul +@if "%1" NEQ "/CA" goto L_CLEAN_DONE +@if "%1" NEQ "/ca" goto L_CLEAN_DONE +@del /Q *.cfg *.dof *.dsk >nul 2>nul +:L_CLEAN_DONE +@goto L_EXIT + +:L_CLEAR_SKIP +@set DVER=%1 +@rem if exist "%1" +@if "%2" NEQ "" set project=%2 +@if "%project%"=="" goto L_ERROR_PARAM +@set DBASE=%DVER% + +@if not exist "%project%" @( + @echo\ERROR: Not found project file "%project%" + @set E=2 + @set errorlevel=%E% + @echo press any key to exit>con + @pause >nul + @goto L_EXIT +) + +@rem Calculate Project specified options file name (Extract File Name ...): + +@set project_path= +@for /F "delims=" %%i in ("%project%") do @set project_path=%%~di%%~pi +@rem .l log +@rem @echo\path=%project_path%>con + +@set project_name= +@for /F "delims=" %%i in ("%project%") do @set project_name=%%~ni +@rem .l log +@rem @echo\name=%project_name%>con + +@set project_type=? +@set project_ext= +@if "%project_name%"=="" @if "%project%"=="?" goto L_PEXT + +@rem .1 variant 1 +@rem @for /F "delims=" %%i in ("%project%") do @set project_ext=%%~xi +@rem @for /F "delims=." %%i in ("%project_ext%") do @set project_ext=%%i +@rem .2 variant 2; limitations: exist $project and os supported shot path/names +@set T= +@for /F "delims=" %%i in ("%project%") do @set T=%%~si +@for /F "delims=" %%i in ("%T%") do @set project_ext=%%~xi +@for /F "delims=." %%i in ("%project_ext%") do @set project_ext=%%i +@rem .l +@rem @echo\ext=%project_ext%>con +@rem .e error +@if "%project_ext%"=="" ( + @echo\ERROR: Unsupported project file name "%project%" + @set E=3 + @set errorlevel=%E% + @echo press any key to exit>con + @pause >nul + @goto L_EXIT +) +@rem .l +@rem @echo\ext=%project_ext%>con +@rem .c check + @rem .......................... lower +@if %project_ext%==pas @( + set project_ext=pas + set project_type=u_pas +) else @if %project_ext%==pp @( + set project_ext=pp + set project_type=u_pas +) else @if %project_ext%==dpr @( + set project_ext=dpr + set project_type=p_dpr +@rem ) else @if %project_ext%==dpk @( +@rem set project_ext=dpk +@rem set project_type=p_dpk +@rem ) else @if %project_ext%==lpr @( +@rem set project_ext=lpr +@rem set project_type=p_lpr +) else @if %project_ext%==rps @( + set project_ext=rps + set project_type=p_pas + @rem .......................... upper +) else @if %project_ext%==PAS @( + set project_ext=pas + set project_type=u_pas +) else @if %project_ext%==PP @( + set project_ext=pp + set project_type=u_pas +) else @if %project_ext%==DPR @( + set project_ext=dpr + set project_type=p_dpr +) else @if %project_ext%==DPK @( + set project_ext=dpk + set project_type=p_dpk +@rem ) else @if %project_ext%==LPR @( +@rem set project_ext=lpr +@rem set project_type=p_lpr +@rem ) else @if %project_ext%==LPK @( +@rem set project_ext=lpk +@rem set project_type=p_lpk +) else @if %project_ext%==RPS @( + set project_ext=rps + set project_type=p_pas + @rem .......................... +) else @( + @echo\ERROR: Unsupported file type "%project_ext%" + @set E=4 + @set errorlevel=%E% + @echo press any key to exit>con + @pause >nul + @goto L_EXIT +) +@rem .l +@rem @echo\ext=%project_ext%>con +@rem @echo\type=%project_type%>con +:L_PEXT + +@rem Clear user Envinronments +@set dccilOpt= +@set bccilOpt= + +@set UserLib=. +@set UserLibI=. +@set UserLibO=. +@set UserLibR=. +@set UserPack= +@set UserCOpt= +@set DEBUG_BATCH=0 +@set CleanDcc32Log=1 +@set UsePack=0 +@set DEBUG=0 +@set MAPFILE=1 +@set TRACE_STACK_SOURCE=1 +@set JDBG=0 +@set Fmx=0 + +@rem set platform variables: + +@set COMMAND= +@set DELPHI_ROOTDIR= +@set KEY=HKCU +@set Platform= +@set DelphiName= +@set ide_name= +@set REGPATH= +@set DXVER=? +@set PLIB= +@set PREL= +@set xlinker= +@set ndklibpath= +@set XOS=win +@set plfm=w32 +@set slib=\win32 + +@set pd=\ +@set vd=; + +@if "%DVER%"=="30w32" set DVER=30 +@if "%DVER%"=="D30" set DVER=30 + +@if "%DVER%"=="29w32" set DVER=29 +@if "%DVER%"=="D29" set DVER=29 + +@if "%DVER%"=="28w32" set DVER=28 +@if "%DVER%"=="D28" set DVER=28 + +@if "%DVER%"=="27w32" set DVER=27 +@if "%DVER%"=="D27" set DVER=27 + +@if "%DVER%"=="26w32" set DVER=26 +@if "%DVER%"=="D26" set DVER=26 + +@if "%DVER%"=="25w32" set DVER=25 +@if "%DVER%"=="D25" set DVER=25 + +@if "%DVER%"=="24w32" set DVER=24 +@if "%DVER%"=="D24" set DVER=24 + +@if "%DVER%"=="23w32" set DVER=23 +@if "%DVER%"=="D23" set DVER=23 + +@if "%DVER%"=="22w32" set DVER=22 +@if "%DVER%"=="D22" set DVER=22 + +@if "%DVER%"=="21w32" set DVER=21 +@if "%DVER%"=="D21" set DVER=21 + +@if "%DVER%"=="20w32" set DVER=20 +@if "%DVER%"=="D20" set DVER=20 + +@if "%DVER%"=="19w32" set DVER=19 +@if "%DVER%"=="D19" set DVER=19 + +@if "%DVER%"=="18w32" set DVER=18 +@if "%DVER%"=="D18" set DVER=18 + +@if "%DVER%"=="17w32" set DVER=17 +@if "%DVER%"=="D17" set DVER=17 + +@if "%DVER%"=="16w32" set DVER=16 +@if "%DVER%"=="D16" set DVER=16 + +@if "%DVER%"=="D15" set DVER=15 +@if "%DVER%"=="D14" set DVER=14 +@if "%DVER%"=="D12" set DVER=12 +@if "%DVER%"=="D11" set DVER=11 +@if "%DVER%"=="D10" set DVER=10 +@if "%DVER%"=="D9" set DVER=9 +@if "%DVER%"=="D8" set DVER=8 +@if "%DVER%"=="D7" set DVER=7 +@if "%DVER%"=="K3" set DVER=k3 +@if "%DVER%"=="D6" set DVER=6 +@if "%DVER%"=="D5" set DVER=5 +@if "%DVER%"=="D4" set DVER=4 +@if "%DVER%"=="D3" set DVER=3 +@if "%DVER%"=="" set DVER=0 + +@if "%DVER%"=="30arm" set DVER=30arm32 +@if "%DVER%"=="29arm" set DVER=29arm32 +@if "%DVER%"=="28arm" set DVER=28arm32 +@if "%DVER%"=="27arm" set DVER=27arm32 +@if "%DVER%"=="26arm" set DVER=26arm32 +@if "%DVER%"=="25arm" set DVER=25arm32 +@if "%DVER%"=="24arm" set DVER=24arm32 +@if "%DVER%"=="23arm" set DVER=23arm32 +@if "%DVER%"=="22arm" set DVER=22arm32 +@if "%DVER%"=="21arm" set DVER=21arm32 +@if "%DVER%"=="20arm" set DVER=20arm32 +@if "%DVER%"=="19arm" set DVER=19arm32 +@if "%DVER%"=="18arm" set DVER=18arm32 + +@if "%DVER%"=="30osx" set DVER=30osx32 +@if "%DVER%"=="29osx" set DVER=29osx32 +@if "%DVER%"=="28osx" set DVER=28osx32 +@if "%DVER%"=="27osx" set DVER=27osx32 +@if "%DVER%"=="26osx" set DVER=26osx32 +@if "%DVER%"=="25osx" set DVER=25osx32 +@if "%DVER%"=="24osx" set DVER=24osx32 +@if "%DVER%"=="23osx" set DVER=23osx32 +@if "%DVER%"=="22osx" set DVER=22osx32 +@if "%DVER%"=="21osx" set DVER=21osx32 +@if "%DVER%"=="20osx" set DVER=20osx32 +@if "%DVER%"=="19osx" set DVER=19osx32 +@if "%DVER%"=="18osx" set DVER=18osx32 +@if "%DVER%"=="17osx" set DVER=17osx32 +@if "%DVER%"=="16osx" set DVER=16osx32 + +@if "%DVER%"=="15w" set DVER="15" +@if "%DVER%"=="14w" set DVER="14" +@if "%DVER%"=="14W" set DVER="14" +@if "%DVER%"=="12w" set DVER="12" +@if "%DVER%"=="12W" set DVER="12" +@if "%DVER%"=="11w" set DVER="11" +@if "%DVER%"=="11W" set DVER="11" +@if "%DVER%"=="10w" set DVER="10" +@if "%DVER%"=="10W" set DVER="10" +@if "%DVER%"=="9w" set DVER="9" +@if "%DVER%"=="9W" set DVER="9" +@if "%DVER%"=="8" set DVER=BDS +@if "%DVER%"=="bds" set DVER=BDS + +@if "%DVER%"=="11N" goto L_SET_BDS +@if "%DVER%"=="11n" goto L_SET_BDS +@if "%DVER%"=="10N" goto L_SET_BDS +@if "%DVER%"=="10n" goto L_SET_BDS +@if "%DVER%"=="9N" goto L_SET_BDS +@if "%DVER%"=="9n" goto L_SET_BDS +@if "%DVER%"=="D.Net1" goto L_SET_DNET1 +@if "%DVER%"=="D.NET1" goto L_SET_DNET1 +@if "%DVER%"=="d.net1" goto L_SET_DNET1 +@if "%DVER%"=="BDS" goto L_SET_BDS + +@if "%DVER%"=="B3" goto L_SET_BUILDER +@if "%DVER%"=="b3" goto L_SET_BUILDER +@if "%DVER%"=="B4" goto L_SET_BUILDER +@if "%DVER%"=="b4" goto L_SET_BUILDER +@if "%DVER%"=="B5" goto L_SET_BUILDER +@if "%DVER%"=="b5" goto L_SET_BUILDER +@if "%DVER%"=="B6" goto L_SET_BUILDER +@if "%DVER%"=="b6" goto L_SET_BUILDER + +@if "%DVER%" NEQ "30w64" goto L_30w64_Done +@set DVER=30 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_30w64_Done + +@if "%DVER%" NEQ "30aarm32" goto L_30aarm32_Done +@set DVER=30 +@set XOS=android +@set plfm=aarm32 +@set slib=\android +@goto L_PLFM +:L_30aarm32_Done + +@if "%DVER%" NEQ "30osx32" goto L_30osx32_Done +@set DVER=30 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_30osx32_Done + +@if "%DVER%" NEQ "30iosarm32" goto L_30iosarm32_Done +@set DVER=30 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice32 +@goto L_PLFM +:L_30iosarm32_Done + +@if "%DVER%" NEQ "30iosarm64" goto L_30iosarm64_Done +@set DVER=30 +@set XOS=ios +@set plfm=iosarm64 +@set slib=\iosDevice64 +@goto L_PLFM +:L_30iosarm64_Done + +@if "%DVER%" NEQ "30ioss" goto L_30ioss32_Done +@set DVER=30 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_30ioss32_Done + +@if "%DVER%" NEQ "29w64" goto L_29w64_Done +@set DVER=29 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_29w64_Done + +@if "%DVER%" NEQ "29aarm32" goto L_29aarm32_Done +@set DVER=29 +@set XOS=android +@set plfm=aarm32 +@set slib=\android +@goto L_PLFM +:L_29aarm32_Done + +@if "%DVER%" NEQ "29osx32" goto L_29osx32_Done +@set DVER=29 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_29osx32_Done + +@if "%DVER%" NEQ "29iosarm32" goto L_29iosarm32_Done +@set DVER=29 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice32 +@goto L_PLFM +:L_29iosarm32_Done + +@if "%DVER%" NEQ "29iosarm64" goto L_29iosarm64_Done +@set DVER=29 +@set XOS=ios +@set plfm=iosarm64 +@set slib=\iosDevice64 +@goto L_PLFM +:L_29iosarm64_Done + +@if "%DVER%" NEQ "29ioss" goto L_29ioss32_Done +@set DVER=29 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_29ioss32_Done + +@if "%DVER%" NEQ "28w64" goto L_28w64_Done +@set DVER=28 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_28w64_Done + +@if "%DVER%" NEQ "28aarm32" goto L_28aarm32_Done +@set DVER=28 +@set XOS=android +@set plfm=aarm32 +@set slib=\android +@goto L_PLFM +:L_28aarm32_Done + +@if "%DVER%" NEQ "28osx32" goto L_28osx32_Done +@set DVER=28 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_28osx32_Done + +@if "%DVER%" NEQ "28iosarm32" goto L_28iosarm32_Done +@set DVER=28 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice32 +@goto L_PLFM +:L_28iosarm32_Done + +@if "%DVER%" NEQ "28iosarm64" goto L_28iosarm64_Done +@set DVER=28 +@set XOS=ios +@set plfm=iosarm64 +@set slib=\iosDevice64 +@goto L_PLFM +:L_28iosarm64_Done + +@if "%DVER%" NEQ "28ioss" goto L_28ioss32_Done +@set DVER=28 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_28ioss32_Done + +@if "%DVER%" NEQ "27w64" goto L_27w64_Done +@set DVER=27 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_27w64_Done + +@if "%DVER%" NEQ "27aarm32" goto L_27aarm32_Done +@set DVER=27 +@set XOS=android +@set plfm=aarm32 +@set slib=\android +@goto L_PLFM +:L_27aarm32_Done + +@if "%DVER%" NEQ "27osx32" goto L_27osx32_Done +@set DVER=27 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_27osx32_Done + +@if "%DVER%" NEQ "27iosarm32" goto L_27iosarm32_Done +@set DVER=27 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice32 +@goto L_PLFM +:L_27iosarm32_Done + +@if "%DVER%" NEQ "27iosarm64" goto L_27iosarm64_Done +@set DVER=27 +@set XOS=ios +@set plfm=iosarm64 +@set slib=\iosDevice64 +@goto L_PLFM +:L_27iosarm64_Done + +@if "%DVER%" NEQ "27ioss" goto L_27ioss32_Done +@set DVER=27 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_27ioss32_Done + +@if "%DVER%" NEQ "26w64" goto L_26w64_Done +@set DVER=26 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_26w64_Done + +@if "%DVER%" NEQ "26aarm32" goto L_26aarm32_Done +@set DVER=26 +@set XOS=android +@set plfm=aarm32 +@set slib=\android +@goto L_PLFM +:L_26aarm32_Done + +@if "%DVER%" NEQ "26osx32" goto L_26osx32_Done +@set DVER=26 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_26osx32_Done + +@if "%DVER%" NEQ "26iosarm32" goto L_26iosarm32_Done +@set DVER=26 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice32 +@goto L_PLFM +:L_26iosarm32_Done + +@if "%DVER%" NEQ "26iosarm64" goto L_26iosarm64_Done +@set DVER=26 +@set XOS=ios +@set plfm=iosarm64 +@set slib=\iosDevice64 +@goto L_PLFM +:L_26iosarm64_Done + +@if "%DVER%" NEQ "26ioss" goto L_26ioss32_Done +@set DVER=26 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_26ioss32_Done + +@if "%DVER%" NEQ "25w64" goto L_25w64_Done +@set DVER=25 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_25w64_Done + +@if "%DVER%" NEQ "25aarm32" goto L_25aarm32_Done +@set DVER=25 +@set XOS=android +@set plfm=aarm32 +@set slib=\android +@goto L_PLFM +:L_25aarm32_Done + +@if "%DVER%" NEQ "25osx32" goto L_25osx32_Done +@set DVER=25 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_25osx32_Done + +@if "%DVER%" NEQ "25iosarm32" goto L_25iosarm32_Done +@set DVER=25 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice32 +@goto L_PLFM +:L_25iosarm32_Done + +@if "%DVER%" NEQ "25iosarm64" goto L_25iosarm64_Done +@set DVER=25 +@set XOS=ios +@set plfm=iosarm64 +@set slib=\iosDevice64 +@goto L_PLFM +:L_25iosarm64_Done + +@if "%DVER%" NEQ "25ioss" goto L_25ioss32_Done +@set DVER=25 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_25ioss32_Done + +@if "%DVER%" NEQ "24w64" goto L_24w64_Done +@set DVER=24 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_24w64_Done + +@if "%DVER%" NEQ "24aarm32" goto L_24aarm32_Done +@set DVER=24 +@set XOS=android +@set plfm=aarm32 +@set slib=\android +@goto L_PLFM +:L_24aarm32_Done + +@if "%DVER%" NEQ "24osx32" goto L_24osx32_Done +@set DVER=24 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_24osx32_Done + +@if "%DVER%" NEQ "24iosarm32" goto L_24iosarm32_Done +@set DVER=24 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice32 +@goto L_PLFM +:L_24iosarm32_Done + +@if "%DVER%" NEQ "24iosarm64" goto L_24iosarm64_Done +@set DVER=24 +@set XOS=ios +@set plfm=iosarm64 +@set slib=\iosDevice64 +@goto L_PLFM +:L_24iosarm64_Done + +@if "%DVER%" NEQ "24ioss" goto L_24ioss32_Done +@set DVER=24 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_24ioss32_Done + +@if "%DVER%" NEQ "23w64" goto L_23w64_Done +@set DVER=23 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_23w64_Done + +@if "%DVER%" NEQ "23aarm32" goto L_23aarm32_Done +@set DVER=23 +@set XOS=android +@set plfm=aarm32 +@set slib=\android +@goto L_PLFM +:L_23aarm32_Done + +@if "%DVER%" NEQ "23osx32" goto L_23osx32_Done +@set DVER=23 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_23osx32_Done + +@if "%DVER%" NEQ "23iosarm32" goto L_23iosarm32_Done +@set DVER=23 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice32 +@goto L_PLFM +:L_23iosarm32_Done + +@if "%DVER%" NEQ "23iosarm64" goto L_23iosarm64_Done +@set DVER=23 +@set XOS=ios +@set plfm=iosarm64 +@set slib=\iosDevice64 +@goto L_PLFM +:L_23iosarm64_Done + +@if "%DVER%" NEQ "23ioss" goto L_23ioss32_Done +@set DVER=23 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_23ioss32_Done + +@rem XE8 Win64 +@if "%DVER%" NEQ "22w64" goto L_22w64_Done +@set DVER=22 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_22w64_Done + +@rem XE8 Android arm32 +@if "%DVER%" NEQ "22aarm32" goto L_22aarm32_Done +@set DVER=22 +@set XOS=android +@set plfm=aarm32 +@set slib=\android +@goto L_PLFM +:L_22aarm32_Done + +@rem XE8 OSX +@if "%DVER%" NEQ "22osx32" goto L_22osx32_Done +@set DVER=22 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_22osx32_Done + +@if "%DVER%" NEQ "22iosarm32" goto L_22iosarm32_Done +@set DVER=22 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice +@goto L_PLFM +:L_22iosarm32_Done + +@if "%DVER%" NEQ "22iosarm64" goto L_22iosarm64_Done +@set DVER=22 +@set XOS=ios +@set plfm=iosarm64 +@set slib=\iosDevice64 +@goto L_PLFM +:L_22iosarm64_Done + +@rem XE8 IOS Simulator +@if "%DVER%" NEQ "22ioss" goto L_22ioss32_Done +@set DVER=22 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_22ioss32_Done + +@rem XE7 Win64 +@if "%DVER%" NEQ "21w64" goto L_21w64_Done +@set DVER=21 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_21w64_Done + +@rem XE7 Android arm32 +@if "%DVER%" NEQ "21aarm32" goto L_21aarm32_Done +@set DVER=21 +@set XOS=android +@set plfm=aarm32 +@set slib=\android +@goto L_PLFM +:L_21aarm32_Done + +@rem XE7 OSX +@if "%DVER%" NEQ "21osx32" goto L_21osx32_Done +@set DVER=21 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_21osx32_Done + +@if "%DVER%" NEQ "21iosarm32" goto L_21iosarm32_Done +@set DVER=21 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice +@goto L_PLFM +:L_21iosarm32_Done + +@if "%DVER%" NEQ "21iosarm64" goto L_21iosarm64_Done +@echo ERROR: platform not suppurted +@goto L_ERROR_SKIPCMD +:L_21iosarm64_Done + +@rem XE7 IOS Simulator +@if "%DVER%" NEQ "21ioss" goto L_21ioss32_Done +@set DVER=21 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_21ioss32_Done + +@rem XE6 Win64 +@if "%DVER%" NEQ "20w64" goto L_20w64_Done +@set DVER=20 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_20w64_Done + +@rem XE6 Android arm32 +@if "%DVER%" NEQ "20aarm32" goto L_20aarm32_Done +@set DVER=20 +@set XOS=android +@set plfm=aarm32 +@set slib=\android +@goto L_PLFM +:L_20aarm32_Done + +@rem XE6 OSX +@if "%DVER%" NEQ "20osx32" goto L_20osx32_Done +@set DVER=20 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_20osx32_Done + +@if "%DVER%" NEQ "20iosarm32" goto L_20iosarm32_Done +@set DVER=20 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice +@goto L_PLFM +:L_20iosarm32_Done + +@if "%DVER%" NEQ "20iosarm64" goto L_20iosarm64_Done +@echo ERROR: platform not suppurted +@goto L_ERROR_SKIPCMD +:L_20iosarm64_Done + +@rem XE6 IOS Simulator +@if "%DVER%" NEQ "20ioss" goto L_20ioss32_Done +@set DVER=20 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_20ioss32_Done + +@rem XE5 Win64 +@if "%DVER%" NEQ "19w64" goto L_19w64_Done +@set DVER=19 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_19w64_Done + +@rem XE5 Android arm32 +@if "%DVER%" NEQ "19aarm32" goto L_19aarm32_Done +@set DVER=19 +@set XOS=android +@set plfm=aarm32 +@set slib=\android +@goto L_PLFM +:L_19aarm32_Done + +@rem XE5 OSX +@if "%DVER%" NEQ "19osx32" goto L_19osx32_Done +@set DVER=19 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_19osx32_Done + +@if "%DVER%" NEQ "19iosarm32" goto L_19iosarm32_Done +@set DVER=19 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice +@goto L_PLFM +:L_19iosarm32_Done + +@if "%DVER%" NEQ "19iosarm64" goto L_19iosarm64_Done +@echo ERROR: platform not suppurted +@goto L_ERROR_SKIPCMD +:L_19iosarm64_Done + +@rem XE5 IOS Simulator +@if "%DVER%" NEQ "19ioss" goto L_19ioss32_Done +@set DVER=19 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_19ioss32_Done + +@rem XE4 Win64 +@if "%DVER%" NEQ "18w64" goto L_18w64_Done +@set DVER=18 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_18w64_Done + +@rem XE4 Android arm32 +@if "%DVER%" NEQ "18aarm32" goto L_18aarm32_Done +@echo ERROR: platform not suppurted +@goto L_ERROR_SKIPCMD +:L_18aarm32_Done + +@rem XE4 OSX +@if "%DVER%" NEQ "18osx32" goto L_18osx32_Done +@set DVER=18 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_18osx32_Done + +@if "%DVER%" NEQ "18iosarm32" goto L_18iosarm32_Done +@set DVER=18 +@set XOS=ios +@set plfm=iosarm32 +@set slib=\iosDevice +@goto L_PLFM +:L_18iosarm32_Done + +@if "%DVER%" NEQ "18iosarm64" goto L_18iosarm64_Done +@echo ERROR: platform not suppurted +@goto L_ERROR_SKIPCMD +:L_18iosarm64_Done + +@rem XE4 IOS Simulator +@if "%DVER%" NEQ "18ioss" goto L_18ioss32_Done +@set DVER=18 +@set XOS=ios +@set plfm=ioss32 +@set slib=\iossimulator +@goto L_PLFM +:L_18ioss32_Done + +@rem XE3 Win64 +@if "%DVER%" NEQ "17w64" goto L_17w64_Done +@set DVER=17 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_17w64_Done + +@rem XE3 OSX +@if "%DVER%" NEQ "17osx32" goto L_17osx32_Done +@set DVER=17 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@goto L_PLFM +:L_17osx32_Done + +@rem XE2 Win64 +@if "%DVER%" NEQ "16w64" goto L_16w64_Done +@set DVER=16 +@set plfm=w64 +@set slib=\win64 +@goto L_PLFM +:L_16w64_Done + +@rem XE2 OSX +@if "%DVER%" NEQ "16osx32" goto L_16osx32_Done +@set DVER=16 +@set XOS=osx +@set plfm=osx32 +@set slib=\osx32 +@rem @goto L_PLFM +:L_16osx32_Done + +:L_PLFM +@rem @echo DBG: %%XOS%%=%XOS%>con +@if "%XOS%" NEQ "win" set Fmx=1 + +@rem XE +@if %DVER% LEQ 15 set slib= + +@if "%DVER%"=="k3" set plfm=linux +@if "%DVER%"=="k3" set slib=\linux + +@set DXVER=%DVER% +@if "%DVER%"=="9" set DXVER=09 +@if "%DVER%"=="8" set DXVER=08 +@if "%DVER%"=="7" set DXVER=07 +@if "%DVER%"=="k3" set DXVER=06 +@if "%DVER%"=="6" set DXVER=06 +@if "%DVER%"=="5" set DXVER=05 +@if "%DVER%"=="4" set DXVER=04 +@if "%DVER%"=="3" set DXVER=03 + +@set Platform=DX +@if "%DVER%"=="k3" set Platform=kylix +@if "%Platform%"=="kylix" set pd=/ +@if "%Platform%"=="kylix" set vd=: +@if "%Platform%"=="kylix" set DelphiName=CrossKylix +@if "%Platform%"=="kylix" goto L_PLATFORM_DONE + +@set ide_name=RAD Studio +@set DelphiName=BDS +@set REGPATH=\Software\Embarcadero\BDS + +@if %DVER% GEQ 12 if %DVER% LEQ 14 set REGPATH=\Software\CodeGear\BDS +@if %DVER% GEQ 8 if %DVER% LEQ 11 set REGPATH=\Software\Borland\BDS +@if %DVER% LEQ 7 set REGPATH=\Software\Borland\Delphi +@if %DVER% LEQ 7 set DelphiName=Delphi +@if %DVER% LEQ 7 set ide_name=Delphi %DVER% +@if %DVER% LEQ 5 set KEY=HKLM + +@if %DVER% GEQ 16 goto L_IDE_NAME_XE +@if %DVER% GEQ 9 set /a ide_name=2005-9+%DVER% +@if %DVER% == 12 set /a ide_name+=1 +@if %DVER% GEQ 9 set ide_name=RAD Studio %ide_name% + +:L_IDE_NAME_XE +@set xe= +@if %DVER% GEQ 16 set /a xe=%DVER%-14 +@if %DVER% GEQ 15 set ide_name=RAD Studio XE%xe% + +@if %DVER% GEQ 14 if %DVER% LEQ 19 set /a DVER-=1 +@if %DVER% GEQ 9 set /a DVER-=6 + +@rem @echo ### "%ide_name%" REGPATH=($REG:%KEY%%REGPATH%\%DVER%.0\RootDir) + +:L_PLATFORM_DONE +@goto L_SET_DONE + +:L_SET_DNET1 +@set Platform=D.Net1 +@set DVER=1 +@set KEY=HKLM +@set REGPATH=\Software\Borland\Delphi for .NET Preview +@set DelphiName=Delphi.Net +@goto L_SET_DONE + +:L_SET_BDS +@set Platform=DELPHI_NET +@if "%DVER%"=="11N" set DVER=5 +@if "%DVER%"=="11n" set DVER=5 +@if "%DVER%"=="10N" set DVER=4 +@if "%DVER%"=="10n" set DVER=4 +@if "%DVER%"=="9N" set DVER=3 +@if "%DVER%"=="9n" set DVER=3 +@set KEY=HKCU +@set REGPATH=\Software\Borland\BDS +@set DelphiName=Delphi.Net +@goto L_SET_DONE + +:L_SET_BUILDER +@set Platform=CB +@set REGPATH=\SOFTWARE\Borland\C++Builder +@if "%DVER%"=="B8" set DVER=8 +@if "%DVER%"=="B7" set DVER=7 +@if "%DVER%"=="B6" set DVER=6 +@if "%DVER%"=="B5" set DVER=5 +@if "%DVER%"=="B4" set DVER=4 +@if "%DVER%"=="B3" set DVER=1 +@set KEY=HKLM +@if %DVER% GEQ 6 set KEY=HKCU +@set DelphiName=C++Builder + +:L_SET_DONE +@rem read compiler root directory from registry: + +@if "%Platform%" NEQ "kylix" goto L_PATH_FROM_REG +:L_PATH_FOR_KYLIX +@if "%CROSSKYLIX_DIR%"=="" @set CROSSKYLIX_DIR=C:\delphi\tools\CrossKylix +@if "%CROSSKYLIX_LNX%"=="" @set CROSSKYLIX_LNX=/C/delphi/tools/CrossKylix +@set ide_name=CrossKylix +@rem @goto L_PATH_FROM_REG_DONE +@goto L_PATH_KYLIX + +:L_PATH_FROM_REG +@rem 1 +@rem @for /F "skip=2 tokens=1,2,3*" %%i in ('REG QUERY "%KEY%%REGPATH%\%DVER%.0" /v RootDir') do if "%%i"=="RootDir" @set DELPHI_ROOTDIR=%%~dpsk +@rem @call :RemoveRigthSplash DELPHI_ROOTDIR +@rem 2 +@call :GetRegValuePath "%KEY%%REGPATH%\%DVER%.0" RootDir DELPHI_ROOTDIR +@rem . +@echo DELPHI_ROOTDIR="%DELPHI_ROOTDIR%">con +@if "%DELPHI_ROOTDIR%"=="" goto L_ERROR_DX_ROOTDIR +:L_PATH_FROM_REG_DONE + +@rem define system envinronment path: + +@if "%Platform%"=="DELPHI_NET" goto L_PATH_DELPHI_NET +@if "%Platform%"=="D.Net1" goto L_PATH_DNET1 +@if "%Platform%"=="kylix" goto L_PATH_KYLIX + +@rem TODO: read common bpl from registry +@if exist "%DELPHI_ROOTDIR%\projects\bpl\" set path=%DELPHI_ROOTDIR%\projects\bpl;%path% +@set path=%DELPHI_ROOTDIR%\bin;%path% +@rem OLD delphi ide replace system dll priority +@if exist "%DELPHI_ROOTDIR%\bin\system32\" set path=%DELPHI_ROOTDIR%\Bin\system32;%path% + +@goto L_PATH_DONE +:L_PATH_DNET1 +:L_PATH_DELPHI_NET +@rem TODO: .Net SDK Assemblies +@rem TODO: BDS Shared Assemblies +@set path=%DELPHI_ROOTDIR%\Bin;%DELPHI_ROOTDIR%\projects\assemblies;%path% +@goto L_PATH_DONE +:L_PATH_KYLIX +@set path=%CROSSKYLIX_DIR%;%path% +@rem @goto L_PATH_DONE +:L_PATH_DONE + +@rem Set User Envinronments +@if "%3" neq "/c" goto l_cmd_dcc +@if not exist "%SystemRoot%\cfg_dcc.cmd" goto l_cmd_dcc +@call "%SystemRoot%\cfg_dcc.cmd" +@rem @goto l_cmd_done +:l_cmd_dcc +@if not exist "cfg_dcc.cmd" goto l_cmd_common +@call "cfg_dcc.cmd" +@rem @goto l_cmd_done +:l_cmd_common +@if not exist "common.cmd" goto l_cmd_fn +@call "common.cmd" +@rem @goto l_cmd_done +:l_cmd_fn +@if exist "%project_name%.cmd" call "%project_name%.cmd" +:l_cmd_done + +@if "%UserLib%"=="" set UserLib=. +@if "%UserLibI%"=="" set UserLibI=. +@if "%UserLibO%"=="" set UserLibO=. +@if "%UserLibR%"=="" set UserLibR=. +@if "%UserCOpt%"=="." set UserCOpt= + +@set DBG=0 +@if "%DEBUG%" == "1" set DBG=1 +@if "%DEBUG%" NEQ "1" if "%TRACE_STACK_SOURCE%"=="1" set DBG=1 + +@rem define Library path: + +@if "%Platform%"=="D.Net1" goto L_SRC_DNET +@if "%Platform%"=="DELPHI_NET" goto L_SRC_DELPHI_NET +@if "%Platform%"=="kylix" goto L_SRC_KYLIX +@set DLib=%UserLib% +@if "%DXVER%" NEQ "?" if %DXVER% GEQ 15 @( + set PLIB=\win32 + if "%plfm%"=="w64" set PLIB=\win64 + if "%plfm%"=="osx32" set PLIB=\osx32 +) +@if "%DXVER%" NEQ "?" if %DXVER% GEQ 18 @( + if "%plfm%"=="aarm32" set PLIB=\android + @rem if "%plfm%"=="aarm64" set PLIB=\android64 + + if "%plfm%"=="ioss32" set PLIB=\iossimulator + if "%plfm%"=="iosarm32" if %DXVER% GEQ 22 set PLIB=\iosDevice32 + if "%plfm%"=="iosarm32" if %DXVER% LEQ 21 set PLIB=\iosDevice + if "%plfm%"=="iosarm64" set PLIB=\iosDevice64 +) + +@set PLIB=lib%PLIB% +@if "%DXVER%" NEQ "?" if %DXVER% GEQ 15 set PREL=\release +@if .%DBG%==.1 set DLib=%UserLib%;%DELPHI_ROOTDIR%\%PLIB%\debug + +@set DLib=%DLib%;%DELPHI_ROOTDIR%\%PLIB%%PREL% +@if "%XOS%"=="win" set DLib=%DLib%;%DELPHI_ROOTDIR%\imports + @rem @if "%XOS%"=="win" set DLib=%DLib%;%DELPHI_ROOTDIR%\ocx\servers +@if exist "%DELPHI_ROOTDIR%\projects\bpl\" set DLib=%DLib%;%DELPHI_ROOTDIR%\projects\bpl +@if "%XOS%"=="win" set DLib=%DLib%;%DELPHI_ROOTDIR%\source\toolsapi + @rem set DLib=%DLib%;%DELPHI_ROOTDIR%\bin\system32 +@if "%XOS%"=="win" if "%indy%" == "09" @set DLib=%DLib%;%DELPHI_ROOTDIR%\%PLIB%\indy9 +@if "%XOS%"=="win" if "%indy%" NEQ "09" @set DLib=%DLib%;%DELPHI_ROOTDIR%\%PLIB%\indy10 + +@goto L_SRC_DONE + +:L_SRC_DELPHI_NET +@set %UserLibI%=%UserLibI%;%DELPHI_ROOTDIR%\lib +@set %UserLibO%=%UserLibO%;%DELPHI_ROOTDIR%\lib +@set %UserLibR%=%UserLibR%;%DELPHI_ROOTDIR%\lib +@set DLib=%UserLib% +@if .%DBG%==.1 set DLib=%UserLib%;%DELPHI_ROOTDIR%\lib\debug +@set DLib=%DLib%;%DELPHI_ROOTDIR%\lib +@goto L_SRC_DONE +:L_SRC_DNET +@rem delphi .Net Preview: +@set %UserLibI%=%UserLibI%;%DELPHI_ROOTDIR%\units +@set %UserLibO%=%UserLibO%;%DELPHI_ROOTDIR%\units +@set %UserLibR%=%UserLibR%;%DELPHI_ROOTDIR%\units +@set DLib=%UserLib%;%DELPHI_ROOTDIR%\units +@goto L_SRC_DONE +:L_SRC_KYLIX +@set DLib=%UserLib% +@set DLib=%DLib%:%CROSSKYLIX_LNX%/libc +@if .%DBG%==.1 set DLib=%DLib%:%CROSSKYLIX_LNX%/kylix/lib/debug +@if .%DBG%==.1 if "%indy%"=="09" set DLib=%DLib%:%CROSSKYLIX_LNX%/kylix/lib/debug/indy9 +@if .%DBG%==.1 if "%indy%" NEQ "09" set DLib=%DLib%:%CROSSKYLIX_LNX%/kylix/lib/debug/indy10 +@set DLib=%DLib%:%CROSSKYLIX_LNX%/kylix/lib +@set DLib=%DLib%:%CROSSKYLIX_LNX%/kylix/imports +@set DLib=%DLib%:%CROSSKYLIX_LNX%/kylix/source/toolsapi +@if "%indy%"=="09" set DLib=%DLib%:%CROSSKYLIX_LNX%/kylix/lib/indy9 +@if "%indy%" NEQ "09" set DLib=%DLib%:%CROSSKYLIX_LNX%/kylix/lib/indy10 +@rem @set DLib=%DLib%:%CROSSKYLIX_LNX%/kylix/bin +@rem @goto L_SRC_DONE +:L_SRC_DONE + +@rem Build: + +@if "%Platform%"=="DELPHI_NET" goto L_BUILD_DNET +@if "%Platform%"=="D.Net1" goto L_BUILD_DNET +@if "%Platform%"=="CB" goto L_BUILD_BUILDER + +@set t= +@if "%ide_name%" NEQ "" set t= ( %ide_name% ) +@if "%project%" NEQ "?" @echo %project% - start make_prj, ver "%make_prj_ver%"; D%DXVER%%t%: + +@set DCC_OPT=-$J+,R-,I-,Q-,Y-,B-,A+,W-,U-,T-,H+,X+,P+,V+,G+ +@rem EQU, NEQ, LSS, LEQ, GTR, GEQ + +@if "%Platform%"=="kylix" goto L_DCC_OPT_DONE + +@if "%XOS%"=="android" set DCC_OPT=-TX.so %DCC_OPT% +@if "%DEBUG%"=="1" if "%XOS%"=="android" set DCC_OPT=-V -VN %DCC_OPT% + +@set t= +@if "%XOS%"=="win" if %DXVER% LEQ 19 set t=;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE +@if "%XOS%"=="win" if %DXVER% GEQ 15 set t=WinTypes=Winapi.Windows;WinProcs=Winapi.Windows%t%; +@if "%XOS%"=="win" if %DXVER% LEQ 14 set t=WinTypes=Windows;WinProcs=Windows%t%; + +@if %DXVER% LEQ 15 goto L_OPT_A_DONE +@rem XE2 UP +@set t=%t%Generics.Collections=System.Generics.Collections;Generics.Defaults=System.Generics.Defaults +:L_OPT_A_DONE +@if "%t%" NEQ "" set DCC_OPT=%DCC_OPT% -A%t% + +@if %DXVER% GEQ 10 set DCC_OPT=--no-config %DCC_OPT% +@if %DXVER% GEQ 10 set DCC_OPT=%DCC_OPT% -W-SYMBOL_PLATFORM -W-UNIT_PLATFORM -W-GARBAGE +@rem @if %DXVER% GEQ 15 set DCC_OPT= %DCC_OPT% --legacy-ifend --inline:auto --zero-based-strings- + +@if %DXVER% LEQ 15 goto L_NS_DONE +@set t=-NSSystem;Xml;Data;Datasnap;Web;Web.Win;Soap.Win +@if "%XOS%"=="win" set t=%t%;Winapi;System.Win;Data.Win +@if "%XOS%"=="win" if %DXVER% LEQ 19 set t=%t%;BDE +@if "%XOS%"=="win" set t=%t%;Xml.Win;Web.Win + +@if %Fmx% NEQ 1 if "%XOS%"=="win" set t=%t%;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Shell;VCLTee +@if %Fmx% NEQ 0 set t=%t%;Fmx +@set DCC_OPT=%DCC_OPT% %t% +:L_NS_DONE + +:L_DCC_OPT_DONE +@set dccPath=%DELPHI_ROOTDIR%\bin + +@rem @echo DBG: %%xlinker%%=%xlinker% +@if "%xlinker%" NEQ "" goto L_XLINKERS_DONE +@if "%XOS%" NEQ "android" goto L_XLINKER_A_DONE +@set t= +@rem 1 +@rem @for /F "skip=2 tokens=1,2,3*" %%i in ('REG QUERY "%KEY%%REGPATH%\%DVER%.0\PlatformSDKs" /v Default_Android') do @if "%%i"=="Default_Android" for /F "skip=2 tokens=1,2,3*" %%l in ('REG QUERY "%KEY%%REGPATH%\%DVER%.0\PlatformSDKs\%%k" /v NDKArmLinuxAndroidFile') do @if "%%l"=="NDKArmLinuxAndroidFile" set t=%%n +@rem 2 +@call :GetRegValue "%KEY%%REGPATH%\%DVER%.0\PlatformSDKs" Default_Android t +@if "%t%" NEQ "" call :GetRegValue "%KEY%%REGPATH%\%DVER%.0\PlatformSDKs\%t%" NDKArmLinuxAndroidFile t +@set xlinker=%t% +@echo linker.android=%xlinker%>con +@rem @if "%xlinker%"=="" goto L_XLINKERS_DONE +@if "%xlinker%"=="" goto L_ERROR_DX_LINKER +@set xlinker=--linker:%xlinker% +:L_XLINKER_A_DONE +@rem :L_LINKER_OSX_DONE +@rem :L_LINKER_IOS_DONE +:L_XLINKERS_DONE +@rem @echo DBG: %%xlinker%%=%xlinker% +@if "%xlinker%" NEQ "" set DCC_OPT=%DCC_OPT% %xlinker% + +@rem @echo DBG: %%ndklibpath%%=%ndklibpath% +@if "%ndklibpath%" NEQ "" goto L_NDKLIBPATHS_DONE +@if "%XOS%" NEQ "android" goto L_NDKLIBPATH_A_DONE +@set t= +@set s=DelphiNDKLibraryPath +@if %DXVER% LEQ 19 @set s=LibraryPath +@rem 1 +@rem @for /F "skip=2 tokens=1,2,3*" %%i in ('REG QUERY "%KEY%%REGPATH%\%DVER%.0\PlatformSDKs" /v Default_Android') do @if "%%i"=="Default_Android" for /F "skip=2 tokens=1,2,3*" %%l in ('REG QUERY "%KEY%%REGPATH%\%DVER%.0\PlatformSDKs\%%k" /v %s%') do @if "%%l"=="%s%" set t=%%n +@rem 2 +@call :GetRegValue "%KEY%%REGPATH%\%DVER%.0\PlatformSDKs" Default_Android t +@if "%t%" NEQ "" call :GetRegValue "%KEY%%REGPATH%\%DVER%.0\PlatformSDKs\%t%" %s% t + +@set ndklibpath=%t% +@echo ndklibpath.android=%ndklibpath%>con +@rem @if "%ndklibpath%"=="" goto L_NDKLIBPATHS_DONE +@if "%ndklibpath%"=="" goto L_ERROR_DX_LINKER +@set ndklibpath=--libpath:%ndklibpath% +:L_NDKLIBPATH_A_DONE +@rem :L_LINKER_OSX_DONE +@rem :L_LINKER_IOS_DONE +:L_NDKLIBPATHS_DONE +@rem @echo DBG: %%ndklibpath%%=%ndklibpath% +@if "%ndklibpath%" NEQ "" set DCC_OPT=%DCC_OPT% %ndklibpath% + +@rem Windows +@set dccName=dcc32 +@if "%plfm%"=="w64" set dccName=dcc64 + +@rem Android +@if "%plfm%"=="aarm32" set dccName=dccaarm +@if "%plfm%"=="aarm64" set dccName=dccaarm64 + +@rem OSX +@if "%plfm%"=="osx32" set dccName=dccosx + +@rem iOS +@if "%plfm%"=="ioss32" set dccName=dccios32 +@if "%plfm%"=="iosarm32" set dccName=dcciosarm +@if "%plfm%"=="iosarm64" set dccName=dcciosarm64 + +@if "%Platform%"=="kylix" set dccName=ckdcc +@if "%Platform%"=="kylix" set dccPath=%CROSSKYLIX_DIR% + +@set dccName=%dccName%.exe + +@if "%DEBUG%"=="1" set DCC_OPT=%DCC_OPT% -DDEBUG;_DEBUG_ +@if "%DEBUG%"=="0" set DCC_OPT=%DCC_OPT% -$D- +@rem ,$C-,O+ +@if "%DEBUG%" NEQ "0" set DCC_OPT=%DCC_OPT% -$D+,L+,Y+,C-,O- +@if "%MAPFILE%"=="1" set DCC_OPT=%DCC_OPT% -GD +@if "%UserCOpt%" NEQ "" set DCC_OPT=%DCC_OPT% %UserCOpt% + +@rem set DCC_OPT=-Q -M -B %DCC_OPT% +@set DCC_OPT=-M -B %DCC_OPT% +@rem System Unit Recompile: +@rem set DCC_OPT=-v %DCC_OPT% + +@if "%UserLib%" NEQ "" set UserLib=%UserLib%%vd% + +@if "%UserPack%" == "" goto L_USE_PACK_DX +@rem TODO: compile with runtime packages: calculate standard package names +@set DCC_OPT=%DCC_OPT% -LU%UserPack% +:L_USE_PACK_DX + +@if "%project%"=="?" goto L_EXIT +@if "%UserLibO%"=="." @set UserLibO= +@if "%XOS%"=="android" @if "%UserLibO%"=="" set UserLibO=%DLib% +@if "%XOS%"=="android" @if "%UserLibO%" NEQ "" set UserLibO=%UserLibO%;%DLib% +@if "%UserLibO%" NEQ "" @set UserLibO= -O"%UserLibO%" +@set COMMAND=%dccName% %project% %DCC_OPT% -U"%DLib%" -I"%DLib%" -R"%DLib%"%UserLibO% +@rem @call date/t>>dcc32.log +@rem @call time/t>>dcc32.log +@echo GO MAKE: [ %date% %time% ]>>dcc32.log +@echo %COMMAND%>>dcc32.log +@echo\>con +@echo %COMMAND%>con +@echo\>con +@"%dccPath%\%dccName%" %project% %DCC_OPT% -U"%DLib%" -I"%DLib%" -R"%DLib%"%UserLibO% +@set E=%ERRORLEVEL% +@if "%IGNOREERRORLEVEL%"=="1" set E=0 +@rem @echo ERRORLEVEL=%E% +@echo %project% - finish +@if "%E%" NEQ "0" goto L_ERROR + +@rem @echo check exist "%project_name%.map">con +@if not exist "%project_name%.map" goto L_BUILD_DONE +@if "%MakeJclDbgP%" neq "" if not exist "%MakeJclDbgP%"MakeJclDbg.exe set MakeJclDbgP= +@if "%MakeJclDbgO%"=="" set MakeJclDbgO=-J +@echo MakeJclDbg.exe %MakeJclDbgO% %project% +@if "%JDBG%"=="1" call "%MakeJclDbgP%"MakeJclDbg.exe %MakeJclDbgO% %project% + +@goto L_BUILD_DONE + +:L_BUILD_DNET + +@set dccilOpt=-m -nsBorland.Delphi.System -nsBorland.Delphi -nsBorland.Vcl -luSystem.Drawing -luSystem.Data -luSystem.Windows.Forms %dccilOpt% + +@if "%project%"=="?" goto L_EXIT +@if "%UserLibO%"=="." @set UserLibO= +@if "%UserLibO%" NEQ "" @set UserLibO= -O%UserLibO% +@set COMMAND=dccil %dccilOpt% %UserCOpt% %project% -U"%DLib%" -I"%UserLibI%" -R"%UserLibR%"%UserLibO% +@echo ------------------------------------------------------------------------------------------>con +@echo COMMAND=%COMMAND%>con +@echo ------------------------------------------------------------------------------------------>con +@dccil %dccilOpt% %UserCOpt% %project% -U"%DLib%" -I"%UserLibI%" -R"%UserLibR%"%UserLibO% +@set E=%ERRORLEVEL% +@if "%IGNOREERRORLEVEL%"=="1" set E=0 +@if "%E%" NEQ "0" goto L_ERROR + +@goto L_BUILD_DONE + +:L_BUILD_BUILDER +@if "%DVER%"=="1" set DVER=3 +@set BDFIX= +@if "%DVER%"=="3" set BDFIX=;VER110 +@if "%DVER%"=="4" set BDFIX=;VER125 +@if "%DVER%"=="5" set BDFIX=;VER130;BCB +@if "%DVER%"=="6" set BDFIX=;VER140;BCB + +@set DCC_OPT=-$J+,R-,I-,Q-,Y-,B-,A+,W-,U-,T-,H+,X+,P+,V+ + +@if .%DBG%==.0 set DCC_OPT=%DCC_OPT%,D-,$C-,O+ +@if .%DBG%==.1 set DCC_OPT=%DCC_OPT%,D+,L+,C-,O- +@if "%MAPFILE%"=="1" set DCC_OPT=%DCC_OPT% -GD +@if "%UserCOpt%" NEQ "" set DCC_OPT=%DCC_OPT% %UserCOpt% + +@set DCC_OPT=-JPHN %DCC_OPT% +@rem @set DCC_OPT=-M %DCC_OPT% +@rem System Unit Recompile +@rem set DCC_OPT=-v %DCC_OPT% + +@if "%UserLib%" NEQ "" set UserLib=%UserLib%%vd% + +@set UnitDir=%DELPHI_ROOTDIR%\lib\release;%DELPHI_ROOTDIR%\lib\obj;%DELPHI_ROOTDIR%\bin\lib;%DELPHI_ROOTDIR%\release +@set IncludeDir=%DELPHI_ROOTDIR%\include;%DELPHI_ROOTDIR%\include\vcl +@set ResourceDir=%IncludeDir%;%UnitDir% +@set UnitDir=%UserLib%%UnitDir% +@set IncludeDir=%UserLib%%UnitDir% + +@if "%project%"=="?" goto L_EXIT +@set COMMAND=dcc32.exe" -D_RTLDLL;USEPACKAGES%BDFIX% -U%UnitDir% -I%IncludeDir% -R%ResourceDir% %project% %DCC_OPT% +@echo ------------------------------------------------------------------------------------------>con +@echo "%DELPHI_ROOTDIR%\bin\dcc32.exe" -D_RTLDLL;USEPACKAGES%BDFIX% -U%UnitDir% -I%IncludeDir% -R%ResourceDir% %project% %DCC_OPT% %bccOpt%>con +@echo ------------------------------------------------------------------------------------------>con +@"%DELPHI_ROOTDIR%\bin\dcc32.exe" -D_RTLDLL;USEPACKAGES%BDFIX% -U%UnitDir% -I%IncludeDir% -R%ResourceDir% -M %project% %DCC_OPT% +@set E=%ERRORLEVEL% +@if "%IGNOREERRORLEVEL%"=="1" set E=0 +@if "%E%" NEQ "0" goto L_ERROR + +:L_BUILD_DONE +@if "%CleanDcc32Log%"=="1" del dcc32.log >nul 2>nul + +@echo Done. + +@goto L_EXIT + +:L_ERROR_DX_ROOTDIR +@set KEYSTR=HKEY_CURRENT_USER +@if "%ide_name%"=="" set ide_name=%DelphiName% %DVER% +@if "%KEY%"=="HKLM" set KEYSTR=HKEY_LOCAL_MACHIME +@echo ERROR:>con +@echo Cannot find "%ide_name%" (%%DVER%%=%DXVER%)>con +@echo Details:>con +@echo Cannot find registry path:>con +@echo '%KEYSTR%%REGPATH%\%DVER%.0\RootDir'>con +@echo press any key to exit>con +@pause >nul +@goto L_EXIT + +:L_ERROR_DX_LINKER +@if "%ide_name%"=="" set ide_name=%DelphiName% %DVER% +@echo ERROR:>con +@echo Linker not found (%XOS%) "%ide_name%" (%%DVER%%=%DXVER%)>con +@echo press any key to exit>con +@pause >nul +@goto L_EXIT + +:L_HELP +@rem cls +@goto L_HELP_INFO +:L_ERROR_PARAM +@if %xLang%A==ruA @( + @echo ERROR: ­¥¢¥à­ë¥ ¯ à ¬¥âàë>con +) else @( + @echo ERROR: unknown parameters>con +) +:L_HELP_INFO +@echo\make_prj Version %make_prj_ver%>con +@if "%xLang%"=="ru" @( + @echo "make_prj.cmd" - ã⨫¨â  ᡮન/ª®¬¯¨«ï樨 ¯à®¥ªâ /¬®¤ã«ï Delphi/C++Builder/Kylix>con + @echo ---------------------------------------------------------------------------------------------->con + @echo ˆá¯®«ì§®¢ ­¨¥:>con + @echo make_prj.cmd "delphi-compiler" "project_file|?" ["options"]>con + @echo ƒ¤¥:>con + @echo [1] delphi-compiler:>con + @echo 22 - Delphi XE8 for win32>con + @echo 22w64 - Delphi XE8 for win64>con + @echo 22arm32 - Delphi XE8 for arm32>con + @echo 22osx32 - Delphi XE8 for osx32>con + @echo 22ios32 - Delphi XE8 for iOS arm 32>con + @echo 22ios64 - Delphi XE8 for iOS arm 64>con + @echo 22ioss - Delphi XE8 for iOS Simulator>con + @echo ... ... ... ... ........ ... ..>con + @echo 18ios32 - Delphi XE4 for iOS arm 32>con + @echo 18ios64 - Delphi XE4 for iOS arm 64>con + @echo 18ioss - Delphi XE4 for iOS Simulator>con + @echo 17 - Delphi XE3 for win32>con + @echo ... ... ... ... ........ ... ..>con + @echo 16 - Delphi XE2 for win32>con + @echo 16w64 - Delphi XE2 for win64>con + @echo 16osx - Delphi XE2 for osx32>con + @echo 15 - Delphi XE for win32>con + @echo 14 - Delphi 2010 for win32>con + @echo 12 - Delphi 2009 for win32>con + @echo 11 - Delphi 2007 for win32>con + @echo 11N - Delphi 2007 for .net2>con + @echo 10 - Delphi 2006 for win32>con + @echo 10N - Delphi 2006 for .net2>con + @echo 9 - Delphi 2005 for win32>con + @echo 9N - Delphi 2005 for .net1>con + @echo 8 - Delphi 8 for .net1>con + @echo BDS - Delphi 8 for .net1>con + @echo D.Net1 - Delphi for .net1 preview>con + @echo 7 - Delphi 7 for win32>con + @echo k3 - Kylix 3 for linux x86 [ CrossKylix: C:\delphi\tools\CrossKylix ]>con + @echo 6 - Delphi 6 for win32>con + @echo 5 - Delphi 5 for win32>con + @echo 4 - Delphi 4 for win32>con + @echo 3 - Delphi 3 for win32>con + @echo\>con + @echo B6 - C++ Builder 6 for win32>con + @echo B5 - C++ Builder 5 for win32>con + @echo B4 - C++ Builder 4 for win32>con + @echo B3 - C++ Builder 3.5 for win32>con + @echo\>con + @echo /C - Clean - ç¨á⪠ ⥪ã饩 ¤¨à¥ªâ®à¨¨ ®â: [dcu, obj, o, a, drc, vsr ...]>con + @echo /CA - /C + remove "cfg, dof, dsk" Files>con + @echo\>con + @echo [2] "project_file|?" - ˆ¬ï ¯à®¥ªâ /¬®¤ã«ï ¨«¨ ? ¤«ï ãáâ ­®¢ª¨ ¯¥à¥¬¥­­ëå ®ªà㦥­¨ï.>con + @echo\>con + @echo [3] "Options":>con + @echo /c - ¨áª âì ®¡é¨© "%%SystemRoot%%\cfg_dcc.cmd" ®¯¨á뢠î騩 ®¡é¨¥ ­ áâனª¨.>con + @echo\>con + @echo ਬ¥àë:>con + @echo make_prj.cmd 3 Project1.dpr>con + @echo make_prj.cmd 6 Unit1.pas>con + @echo make_prj.cmd B6 Unit1.pas>con + @echo make_prj.cmd 9N my.module.pas>con + @echo make_prj.cmd 16w64 Unit1.pas>con + @echo make_prj.cmd 16osx Unit1.pas>con + @echo make_prj.cmd k3 Unit1.pas>con + @echo make_prj.cmd /C>con + @echo make_prj.cmd D5 ? - ⮫쪮 ãáâ ­®¢ª  ¯¥à¥¬¥­­ëå ®ªà㦥­¨ï>con + @echo make_prj.cmd 6 project1.dpr /c - ¢á¥ ­ áâனª¨ 㪠§ ­­ë ¢ cfg_dcc.cmd>con +) else @( + @echo "make_prj.cmd" - The utility of assembly/compilation of Delphi/C++ Builder/Kylix project/unit/package>con + @echo ---------------------------------------------------------------------------------------------->con + @echo Usage:>con + @echo make_prj.cmd "delphi-compiler" "project_file|?" ["options"]>con + @echo Where:>con + @echo [1] delphi-compiler:>con + @echo 22 - Delphi XE8 for win32>con + @echo 22w64 - Delphi XE8 for win64>con + @echo 22arm32 - Delphi XE8 for arm32>con + @echo 22osx32 - Delphi XE8 for osx32>con + @echo 22ios32 - Delphi XE8 for iOS arm 32>con + @echo 22ios64 - Delphi XE8 for iOS arm 64>con + @echo 22ioss - Delphi XE8 for iOS Simulator>con + @echo ... ... ... ... ........ ... ..>con + @echo 18iosarm32 - Delphi XE4 for iOS arm 32>con + @echo 18iosarm64 - Delphi XE4 for iOS arm 64>con + @echo 18ioss - Delphi XE4 for iOS Simulator>con + @echo 17 - Delphi XE3 for win32>con + @echo ... ... ... ... ........ ... ..>con + @echo 16 - Delphi XE2 for win32>con + @echo 16w64 - Delphi XE2 for win64>con + @echo 16osx - Delphi XE2 for osx32>con + @echo 15 - Delphi XE for win32>con + @echo 14 - Delphi 2010 for win32>con + @echo 12 - Delphi 2009 for win32>con + @echo 11 - Delphi 2007 for win32>con + @echo 11N - Delphi 2007 for .net2>con + @echo 10 - Delphi 2006 for win32>con + @echo 10N - Delphi 2006 for .net2>con + @echo 9 - Delphi 2005 for win32>con + @echo 9N - Delphi 2005 for .net1>con + @echo 8 - Delphi 8 for .net1>con + @echo BDS - Delphi 8 for .net1>con + @echo D.Net1 - Delphi for .net1 preview>con + @echo 7 - Delphi 7 for win32>con + @echo k3 - Kylix 3 for linux x86 [ CrossKylix: C:\delphi\tools\CrossKylix ]>con + @echo 6 - Delphi 6 for win32>con + @echo 5 - Delphi 5 for win32>con + @echo 4 - Delphi 4 for win32>con + @echo 3 - Delphi 3 for win32>con + @echo\>con + @echo B6 - C++ Builder 6 for win32>con + @echo B5 - C++ Builder 5 for win32>con + @echo B4 - C++ Builder 4 for win32>con + @echo B3 - C++ Builder 3.5 for win32>con + @echo\>con + @echo /C - Clean - Cleaning of the current directory from: [dcu, obj, o, a, drc, vsr ...]>con + @echo /CA - /C + Cleaning of the current directory from: "cfg, dof, dsk" Files>con + @echo\>con + @echo [2] "project_file|?" - Name of the project/unit or ? for installation of environment variables only.>con + @echo\>con + @echo [3] "Options":>con + @echo /c - To search common "%%SystemRoot%%\cfg_dcc.cmd" describing for common options.>con + @echo\>con + @echo Examples:>con + @echo make_prj.cmd 3 Project1.dpr>con + @echo make_prj.cmd 6 Unit1.pas>con + @echo make_prj.cmd B6 Unit1.pas>con + @echo make_prj.cmd 9N my.module.pas>con + @echo make_prj.cmd 16w64 Unit1.pas>con + @echo make_prj.cmd 16osx Unit1.pas>con + @echo make_prj.cmd k3 Unit1.pas>con + @echo make_prj.cmd /C>con + @echo make_prj.cmd D5 ? - Only installation of environment variables>con + @echo make_prj.cmd 6 project1.dpr /c - Originally to take adjustments from cfg_dcc.cmd>con +) +@echo ------------------------------------------------------------------------------------------>con +@goto L_EXIT + +:L_ERROR +@if "%E%"=="" set E=%ERRORLEVEL% + +@if "%DEBUG_BATCH%"=="1" goto L_ERROR_LOG + +@echo ------------------------------------------------------------------------------------------>con +@echo PATH=%path%>con +@echo ------------------------------------------------------------------------------------------>con +@echo Error (ERRORLEVEL="%E%").>con +@if "%UserLib%" NEQ "" if "%UserLib%" NEQ "." echo UserLib=%UserLib%>con +@if "%UserPack%" NEQ "" echo UserPack=%UserPack%>con +@echo ------------------------------------------------------------------------------------------>con +@echo command:>con +@echo %COMMAND%>con +@echo ------------------------------------------------------------------------------------------>con + +:L_ERROR_LOG +@rem Clean Log File +@rem @if "%E%"=="0" if "%CleanDcc32Log%"=="1" del dcc32.log >nul 2>nul +@if "%CleanDcc32Log%"=="1" del dcc32.log >nul 2>nul + +@echo ------------------------------------------------------------------------------------------>>dcc32.log +@set>>dcc32.log +@echo . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . >>dcc32.log +@echo Error (ERRORLEVEL="%E%").>>dcc32.log +@echo . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . >>dcc32.log +@echo CD=%cd%>>dcc32.log +@echo . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . >>dcc32.log +@echo PATH=%path%>>dcc32.log +@echo . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . >>dcc32.log +@echo Error (ERRORLEVEL="%E%").>>dcc32.log +@echo UserLib=%UserLib%>>dcc32.log +@echo UserPack=%UserPack%>>dcc32.log +@echo . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . >>dcc32.log +@echo command:>>dcc32.log +@echo %COMMAND%>>dcc32.log +@echo . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . >>dcc32.log + +@if exist "error_handler.cmd" call error_handler.cmd +@if "%SKIP_ERROR%"=="1" goto L_EXIT + +:L_ERROR_SKIPCMD +@if not %xErrorTimeout%A==1A goto L_WAIT_2 +@if "%FARHOME%" NEQ "" goto L_WAIT_2 +@echo Press Crtl+C to quit ... >con +@ping -a -n 10 1.1.1.1 -w 10000>nul +@rem @goto L_WAIT_END +:L_WAIT_2 +@echo !!! ERROR !!! Press any key to exit . . .>con +@pause >nul +:L_WAIT_END +@set errorlevel=1 +@exit 1 + +:L_EXIT +@goto :eof + + +:::::::::::::::::::::::::::::::::::::::::::::::::::::: +:StrLen S L +:::::::::::::::::::::::::::::::::::::::::::::::::::::: TODO: not supported quoted S +@setlocal + @call set S=%%%1%% + @set L=0 + :Loop + @if "%S%"=="" @(endlocal & set "%2=%L%" & goto :eof) + @set /a L=%L%+1 + @set S=%S:~0,-1% +@goto Loop +:::::::::::::::::::::::::::::::::::::::::::::::::::::: + + +:::::::::::::::::::::::::::::::::::::::::::::::::::::: +:RemoveRigthSplash %S% +:::::::::::::::::::::::::::::::::::::::::::::::::::::: :: TODO: StrLen not work when S is quoted +@setlocal + @call set S=%%%~1%% + @call :StrLen S L + @if %L%==0 @goto l_end + @set /a L-=1 + @set C=%%S:~%L%,1%% + @call set "C=%C%" + @if "%C%" NEQ "\" @goto l_end + @set C=%%S:~0,%L%%% + @call set "S=%C%" + :l_end +@endlocal & @set "%1=%S%" & @goto :eof +:::::::::::::::::::::::::::::::::::::::::::::::::::::: + + +:::::::::::::::::::::::::::::::::::::::::::::::::::::: +:xGetRegValue %P% %N% %V% +:::::::::::::::::::::::::::::::::::::::::::::::::::::: :: TODO: N - not work when quoted +@setlocal + @set S= + @call set N=%%%~2%% + @for /F "skip=2 tokens=1,2,3*" %%i in ('REG QUERY "%%%1%%" /v %%%2%%') do @if "%%i"=="%N%" set S=%%k +@endlocal & @set "%3=%S%" & @goto :eof +:::::::::::::::::::::::::::::::::::::::::::::::::::::: + + +:::::::::::::::::::::::::::::::::::::::::::::::::::::: +:GetRegValue P N %V% +:::::::::::::::::::::::::::::::::::::::::::::::::::::: :: TODO: N - not work when quoted +@setlocal + @set P=%1 + @set N=%2 + @set V= + @call :xGetRegValue P N V +@endlocal & @set "%3=%V%" & @goto :eof +:::::::::::::::::::::::::::::::::::::::::::::::::::::: + + +:::::::::::::::::::::::::::::::::::::::::::::::::::::: +:xGetRegValuePath %P% %N% %V% +:::::::::::::::::::::::::::::::::::::::::::::::::::::: :: TODO: N - not work when quoted +@setlocal + @set S= + @call set N=%%%~2%% + @for /F "skip=2 tokens=1,2,3*" %%i in ('REG QUERY "%%%1%%" /v %%%2%%') do @if "%%i"=="%N%" if "%%k" NEQ "" ( + set S=%%k + call :RemoveRigthSplash S + ) +@endlocal & @set "%3=%S%" & @goto :eof +:::::::::::::::::::::::::::::::::::::::::::::::::::::: + + +:::::::::::::::::::::::::::::::::::::::::::::::::::::: +:GetRegValuePath P N %V% +:::::::::::::::::::::::::::::::::::::::::::::::::::::: :: TODO: N - not work when quoted +@setlocal + @set P=%1 + @set N=%2 + @set V= + @call :xGetRegValuePath P N V +@endlocal & @set "%3=%V%" & @goto :eof +:::::::::::::::::::::::::::::::::::::::::::::::::::::: diff --git a/Samples/console_rops/make_xe3_win32.bat b/Samples/console_rops/make_xe3_win32.bat new file mode 100644 index 00000000..bb407623 --- /dev/null +++ b/Samples/console_rops/make_xe3_win32.bat @@ -0,0 +1 @@ +@call make_prj.cmd 17w32 console_rops.dpr \ No newline at end of file diff --git a/Samples/console_rops/make_xe3_win64.bat b/Samples/console_rops/make_xe3_win64.bat new file mode 100644 index 00000000..4bb2409e --- /dev/null +++ b/Samples/console_rops/make_xe3_win64.bat @@ -0,0 +1 @@ +@call make_prj.cmd 17w64 console_rops.dpr \ No newline at end of file diff --git a/Samples/console_rops/rops_inc/sample_include.inc b/Samples/console_rops/rops_inc/sample_include.inc new file mode 100644 index 00000000..a5067a8a --- /dev/null +++ b/Samples/console_rops/rops_inc/sample_include.inc @@ -0,0 +1,11 @@ +{ sample_include.inc } + +procedure println(L: string); +begin + writeln(L); +end; + +procedure make_error(e: string); +begin + RaiseExceptionMessage(e); +end; diff --git a/Samples/console_rops/sample_default.rops b/Samples/console_rops/sample_default.rops new file mode 100644 index 00000000..7016b986 --- /dev/null +++ b/Samples/console_rops/sample_default.rops @@ -0,0 +1,9 @@ +begin + +//writeln('GO:'); + +format('%s; %s',['2','2']); + +//writeln('OK.'); + +end. \ No newline at end of file diff --git a/Samples/console_rops/sample_exception.rops b/Samples/console_rops/sample_exception.rops new file mode 100644 index 00000000..7dcb7fab --- /dev/null +++ b/Samples/console_rops/sample_exception.rops @@ -0,0 +1,3 @@ +begin + RaiseExceptionMessage('demo exception "unhandled"'); +end. diff --git a/Samples/console_rops/sample_exception_handle.rops b/Samples/console_rops/sample_exception_handle.rops new file mode 100644 index 00000000..0f76e982 --- /dev/null +++ b/Samples/console_rops/sample_exception_handle.rops @@ -0,0 +1,36 @@ +//#rps - Remobjects Pascal Script +program sample_exception; + +{$i rops_inc\sample_include.inc} + +var + S: string; +begin + writeln('Start:'); + writeln(''); + + + writeln('script handle exception:'); + try + make_error('demo exception'); + except + S := ' Exception(script): '+ExceptionText; + dbg(S); // # OutputDebugString + println(S); + end; + writeln('script handle exception.'); + + + writeln('unhandled exception:'); + try + RaiseExceptionMessage('demo exception "unhandled"'); + except + println(' raise ...'); + raise; // emulate raise unhandled exception + end; + writeln('unhandled exception.'); + + + writeln(''); + writeln('Done!'); +end. diff --git a/Samples/console_rops/sample_format_openarray.rops b/Samples/console_rops/sample_format_openarray.rops new file mode 100644 index 00000000..e7a04dcd --- /dev/null +++ b/Samples/console_rops/sample_format_openarray.rops @@ -0,0 +1,56 @@ +//#rps - Remobjects Pascal Script +program sample_format; +var + i: integer; + s,sf: string; +begin + writeln('Start:'); + writeln(''); + + s := format('%s',['1']); + writeln(s); + s := format('%s; %s',['2','2']); //FPC: AV + writeln(s); + //s := format('%s; %s; %s',['3','2',3']); //FPC: AV + //writeln(s); +// exit; + + writeln('for:'); + s := ''; + for i := 1 to 25 do begin + s := s + inttostr(i); + sf := format(' [ (%2d), "%s" ]',[i, s]); + writeln(sf); + s := s+','; + //if length(s) mod 4 = 0 then s := ''; + end; + writeln('for.');{} + + writeln('format 90 params: (open array)'); + writeln(format(#13#10#13#10 + + '(%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d),'#13#10 // 10 + + '(%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d),'#13#10 // 20 + + '(%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d),'#13#10 // 30 + + '(%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d),'#13#10 // 40 + + '(%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d),'#13#10 // 50 + + '(%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d),'#13#10 // 60 + + '(%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d),'#13#10 // 70 + + '(%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d),'#13#10 // 80 + + '(%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d), (%2d).'#13#10 // 90 + ,[ + 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, + 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, + 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, + 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, + 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, + 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, + 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, + 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, + 81, 82, 83, 84, 85, 86, 87, 88, 89, 90 + ]) + ); + writeln('format 90 params.'); + + writeln(''); + writeln('Done!'); +end. diff --git a/Samples/console_rops/sample_format_openarray7s.rops b/Samples/console_rops/sample_format_openarray7s.rops new file mode 100644 index 00000000..e59c06b4 --- /dev/null +++ b/Samples/console_rops/sample_format_openarray7s.rops @@ -0,0 +1,9 @@ +var s: string; i: integer; +begin + for i := 0 to 64 do + begin + s := test_openArray7s(['p1,xxxxxxxxx','p2,yyyyyyyyy','p3,zzzzzzzzzzzz', + 'p4,kkkkkkkkkk','p5,lllllllllllll','p6,mmmmmm','p7,nnnnnnnnnn.'+inttostr(i){}]); + end; + writeln(s); +end. \ No newline at end of file diff --git a/Samples/console_rops/sample_format_openarray_fpc_x64_err0.rops b/Samples/console_rops/sample_format_openarray_fpc_x64_err0.rops new file mode 100644 index 00000000..de6b2669 --- /dev/null +++ b/Samples/console_rops/sample_format_openarray_fpc_x64_err0.rops @@ -0,0 +1,4 @@ +//#rps - Remobjects Pascal Script +begin + format('%s; %s',['2','2']); //FPC: AV +end. diff --git a/Samples/console_rops/sample_format_openarray_fpc_x64_err1.rops b/Samples/console_rops/sample_format_openarray_fpc_x64_err1.rops new file mode 100644 index 00000000..11c1c8f1 --- /dev/null +++ b/Samples/console_rops/sample_format_openarray_fpc_x64_err1.rops @@ -0,0 +1,9 @@ +begin + +writeln('GO:'); + +format('%s; %s',['2','2']); + +writeln('OK.'); + +end. \ No newline at end of file diff --git a/Samples/console_rops/sample_hello.rops b/Samples/console_rops/sample_hello.rops new file mode 100644 index 00000000..386b33b4 --- /dev/null +++ b/Samples/console_rops/sample_hello.rops @@ -0,0 +1,4 @@ +//#rps - Remobjects Pascal Script +begin + writeln('Hello script :)'); +end. diff --git a/Samples/console_rops/sample_include.rops b/Samples/console_rops/sample_include.rops new file mode 100644 index 00000000..0908ca35 --- /dev/null +++ b/Samples/console_rops/sample_include.rops @@ -0,0 +1,8 @@ +//#rps - Remobjects Pascal Script +program sample_exception; + +{$i rops_inc\sample_include.inc} + +begin + println('Hello include!'); +end. diff --git a/Samples/console_rops/sample_test_params64.rops b/Samples/console_rops/sample_test_params64.rops new file mode 100644 index 00000000..d8bde389 --- /dev/null +++ b/Samples/console_rops/sample_test_params64.rops @@ -0,0 +1,18 @@ +//#rps - Remobjects Pascal Script +program sample_test_params64; + +procedure fp64_test(); +var r,p64: string; +begin + p64 := '!p64!'; + r := fp64('p1','p2','p3','p4','p5','p6','p7','p8','p9','p10','p11','p12','p13', + 'p14','p15','p16','p17','p18','p19','p20','p21','p22','p23','p24','p25','p26', + 'p27','p28','p29','p30','p31','p32','p33','p34','p35','p36','p37','p38','p39', + 'p40','p41','p42','p43','p44','p45','p46','p47','p48','p49','p50','p51','p52', + 'p53','p54','p55','p56','p57','p58','p59','p60','p61','p62','p63',p64); + writeln('r="'+r+'"'+'; p64="'+p64+'"'); +end; + +begin + fp64_test(); +end. diff --git a/Samples/console_rops/sample_test_params7.rops b/Samples/console_rops/sample_test_params7.rops new file mode 100644 index 00000000..e995e5a0 --- /dev/null +++ b/Samples/console_rops/sample_test_params7.rops @@ -0,0 +1,9 @@ +//#rps - Remobjects Pascal Script +program sample_test_params; +var + s: string; +begin + s := test_params7({p1:Integer}17, {p2: stiring}'s:ok17', {p3: AnsiString}'a:ok17', + {b4:Boolean}True, {d5:Double}17.17, {ca6:AnsiChar}'a', {cw7:WideChar}'w'); + writeln('test_params: "'+s+'"'); +end. From 04343eb6a97f3714d183b320601954454347e2f4 Mon Sep 17 00:00:00 2001 From: Vadim Lou Date: Sat, 2 Mar 2019 09:37:31 +0200 Subject: [PATCH 3/9] Update x86.inc --- Source/x86.inc | 1960 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 1298 insertions(+), 662 deletions(-) diff --git a/Source/x86.inc b/Source/x86.inc index 0b697751..27eff2a9 100644 --- a/Source/x86.inc +++ b/Source/x86.inc @@ -1,323 +1,1121 @@ -{ implementation of x86 abi } -{$ifdef FPC} -{$define PS_ARRAY_ON_STACK} -{$endif} -function RealFloatCall_Register(p: Pointer; - _EAX, _EDX, _ECX: Cardinal; - StackData: Pointer; - StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes) - ): Extended; Stdcall; // make sure all things are on stack -var - E: Extended; -begin - asm - mov ecx, stackdatalen - jecxz @@2 - mov eax, stackdata - @@1: - mov edx, [eax] - push edx - sub eax, 4 - dec ecx - or ecx, ecx - jnz @@1 - @@2: - mov eax,_EAX - mov edx,_EDX - mov ecx,_ECX - call p - fstp tbyte ptr [e] +{ x64.inc } + +{.$O-,D+,L+} // for debug + +{$IFDEF DELPHI} + {$DEFINE PS_RESBEFOREPARAMETERS} + {$DEFINE x64_string_result_as_varparameter} +{$ENDIF} + +{ implementation of x64 abi } +//procedure DebugBreak; external 'Kernel32.dll'; +const + EmptyPChar: array[0..0] of Char = (Char(#0)); + +type + EInvocationError = class(Exception); + +// +// Calculate/Declare defines +// +{$UNDEF X64CALL_ASM} { not change } +{$UNDEF REG_STACK_PTR_OFFSET0} { not change } +{$IFDEF MSWINDOWS}{$DEFINE WINDOWS}{$ENDIF} + +{$IFDEF MSWINDOWS} + {$IFDEF CPUX64} + + {$IFDEF DELPHI} + {$DEFINE X64CALL_ASM} { optional } // ! Successfully on exceptions ! + {$ENDIF} + + {$IFDEF FPC} + {.$DEFINE X64CALL_ASM} { optional } // ! Not recomended : GPF on exception ! + {$ENDIF} + + {$ELSE} + + {$ENDIF} +{$ELSE !MSWINDOWS} + + {$DEFINE X64CALL_ASM} { optional } // TODO: Check pas version (disable "X64CALL_ASM"). + +{$ENDIF !MSWINDOWS} + +{$IFNDEF X64CALL_ASM} // PURE PASCAL version. ! DELPHI/FPC: Successfully on exceptions ! +type + {$IFDEF CPUX64} + t_pstask = array[0..61] of IPointer; + p_pstask = ^t_pstask; + TRegisters = packed record + _RCX, // 0 + _RDX, // 8 + _R8, // 16 + _R9: IPointer; // 24 + _XMM1, // 32 + _XMM2, // 40 + _XMM3: Double; // 48 + case byte of + 0:( + Stack: Pointer; // 56 + Items: {$IFDEF FPC}PtrUInt{$ELSE}IntPtr{$ENDIF}; // 64 + SingleBits: Integer; // 72 + ); + 1:(S: p_pstask); end; - Result := E; -end; - -function RealFloatCall_Other(p: Pointer; - StackData: Pointer; - StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes) - ): Extended; Stdcall; // make sure all things are on stack -var - E: Extended; + {$ENDIF CPUX64} + {$DEFINE REG_STACK_PTR_OFFSET0} { not change } +type + t_pcall_04 = procedure(_rcx,_rdx,_r8,_r9: IPointer); + t_pcall_05 = procedure(_rcx,_rdx,_r8,_r9,p5: IPointer); + t_pcall_06 = procedure(_rcx,_rdx,_r8,_r9,p5,p6: IPointer); + t_pcall_07 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7: IPointer); + t_pcall_08 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8: IPointer); + t_pcall_09 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9: IPointer); + t_pcall_10 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10: IPointer); + t_pcall_11 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11: IPointer); + t_pcall_12 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12: IPointer); + t_pcall_13 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13: IPointer); + t_pcall_14 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14: IPointer); + t_pcall_15 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15: IPointer); + t_pcall_16 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16: IPointer); + t_pcall_17 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17: IPointer); + t_pcall_18 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18: IPointer); + t_pcall_19 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19: IPointer); + t_pcall_20 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20: IPointer); + t_pcall_21 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21: IPointer); + t_pcall_22 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22: IPointer); + t_pcall_23 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23: IPointer); + t_pcall_24 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24: IPointer); + t_pcall_25 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25: IPointer); + t_pcall_26 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26: IPointer); + t_pcall_27 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27: IPointer); + t_pcall_28 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28: IPointer); + t_pcall_29 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29: IPointer); + t_pcall_30 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30: IPointer); + t_pcall_31 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31: IPointer); + t_pcall_32 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32: IPointer); + t_pcall_33 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33: IPointer); + t_pcall_34 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34: IPointer); + t_pcall_35 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35: IPointer); + t_pcall_36 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36: IPointer); + t_pcall_37 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37: IPointer); + t_pcall_38 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38: IPointer); + t_pcall_39 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39: IPointer); + t_pcall_40 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40: IPointer); + t_pcall_41 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41: IPointer); + t_pcall_42 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42: IPointer); + t_pcall_43 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43: IPointer); + t_pcall_44 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44: IPointer); + t_pcall_45 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45: IPointer); + t_pcall_46 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46: IPointer); + t_pcall_47 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47: IPointer); + t_pcall_48 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48: IPointer); + t_pcall_49 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49: IPointer); + t_pcall_50 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50: IPointer); + t_pcall_51 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51: IPointer); + t_pcall_52 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52: IPointer); + t_pcall_53 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53: IPointer); + t_pcall_54 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54: IPointer); + t_pcall_55 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55: IPointer); + t_pcall_56 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56: IPointer); + t_pcall_57 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57: IPointer); + t_pcall_58 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58: IPointer); + t_pcall_59 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59: IPointer); + t_pcall_60 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60: IPointer); + t_pcall_61 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61: IPointer); + t_pcall_62 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62: IPointer); + t_pcall_63 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63: IPointer); + t_pcall_64 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63,p64: IPointer); + t_pcall_65 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63,p64,p65: IPointer); + t_pcall_66 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, + p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, + p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63,p64,p65,p66: IPointer); +procedure x64call({RCX}Address: Pointer;out {RDX}_RAX: IPointer;var {R8}_XMM0: Double; var {R9}R: TRegisters); begin - asm - mov ecx, stackdatalen - jecxz @@2 - mov eax, stackdata - @@1: - mov edx, [eax] - push edx - sub eax, 4 - dec ecx - or ecx, ecx - jnz @@1 - @@2: - call p - fstp tbyte ptr [e] + case R.Items of // stack items count + 00: t_pcall_04(Address)(R._RCX,R._RDX,R._R8,R._R9); + 01: t_pcall_05(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00]); + 02: t_pcall_06(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01]); + 03: t_pcall_07(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02]); + 04: t_pcall_08(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03]); + 05: t_pcall_09(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04]); + 06: t_pcall_10(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05]); + 07: t_pcall_11(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06]); + 08: t_pcall_12(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07]); + 09: t_pcall_13(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08]); + 10: t_pcall_14(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09]); + 11: t_pcall_15(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10]); + 12: t_pcall_16(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11]); + 13: t_pcall_17(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12]); + 14: t_pcall_18(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13]); + 15: t_pcall_19(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14]); + 16: t_pcall_20(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15]); + 17: t_pcall_21(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16]); + 18: t_pcall_22(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17]); + 19: t_pcall_23(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18]); + 20: t_pcall_24(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19]); + 21: t_pcall_25(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20]); + 22: t_pcall_26(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21]); + 23: t_pcall_27(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22]); + 24: t_pcall_28(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23]); + 25: t_pcall_29(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24]); + 26: t_pcall_30(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25]); + 27: t_pcall_31(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26]); + 28: t_pcall_32(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27]); + 29: t_pcall_33(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28]); + 30: t_pcall_34(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29]); + 31: t_pcall_35(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30]); + 32: t_pcall_36(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31]); + 33: t_pcall_37(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32]); + 34: t_pcall_38(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33]); + 35: t_pcall_39(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34]); + 36: t_pcall_40(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35]); + 37: t_pcall_41(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36]); + 38: t_pcall_42(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37]); + 39: t_pcall_43(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38]); + 40: t_pcall_44(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39]); + 41: t_pcall_45(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40]); + 42: t_pcall_46(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41]); + 43: t_pcall_47(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42]); + 44: t_pcall_48(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43]); + 45: t_pcall_49(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44]); + 46: t_pcall_50(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45]); + 47: t_pcall_51(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46]); + 48: t_pcall_52(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47]); + 49: t_pcall_53(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48]); + 50: t_pcall_54(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49]); + 51: t_pcall_55(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50]); + 52: t_pcall_56(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51]); + 53: t_pcall_57(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52]); + 54: t_pcall_58(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53]); + 55: t_pcall_59(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54]); + 56: t_pcall_60(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55]); + 57: t_pcall_61(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], + R.S[56]); + 58: t_pcall_62(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], + R.S[56],R.S[57]); + 59: t_pcall_63(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], + R.S[56],R.S[57],R.S[58]); + 60: t_pcall_64(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], + R.S[56],R.S[57],R.S[58],R.S[59]); + 61: t_pcall_65(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], + R.S[56],R.S[57],R.S[58],R.S[59],R.S[60]); + 62: t_pcall_66(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], + R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], + R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], + R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], + R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], + R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], + R.S[56],R.S[57],R.S[58],R.S[59],R.S[60],R.S[61]); + //} + else + raise EInvocationError.Create('Internal: Parameter count exceeded 64'); end; - Result := E; end; +{$ENDIF} -function RealFloatCall_CDecl(p: Pointer; - StackData: Pointer; - StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes) - ): Extended; Stdcall; // make sure all things are on stack -var - E: Extended; -begin - asm - mov ecx, stackdatalen - jecxz @@2 - mov eax, stackdata - @@1: - mov edx, [eax] - push edx - sub eax, 4 - dec ecx - or ecx, ecx - jnz @@1 - @@2: - call p - fstp tbyte ptr [e] - @@5: - mov ecx, stackdatalen - jecxz @@2 - @@6: - pop edx - dec ecx - or ecx, ecx - jnz @@6 +{$IFDEF X64CALL_ASM} + +{$IFDEF WINDOWS} +type + //{$IFDEF UNICODE_OR_FPC}{$ALIGN 16}{$ENDIF} // For packed record mode + //{$ifdef FPC} + //{$PACKRECORDS 16} + //{$endif} + t_pstask = array[0..61] of IPointer; + p_pstask = ^t_pstask; + TRegisters = packed record + _RCX, // 0 + _RDX, // 8 + _R8, // 16 + _R9: IPointer; // 24 + _XMM1, // 32 + _XMM2, // 40 + _XMM3: Double; // 48 + case byte of + 0:( + Stack: Pointer; // 56 + Items: {$IFDEF FPC}PtrUInt{$ELSE}IntPtr{$ENDIF}; // 64 + SingleBits: Integer; // 72 + ); + 1:(S: p_pstask); end; - Result := E; -end; + PRegisters=^TRegisters; -function RealCall_Register(p: Pointer; - _EAX, _EDX, _ECX: Cardinal; - StackData: Pointer; - StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes) - ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack -var - r: Longint; -begin - asm - mov ecx, stackdatalen - jecxz @@2 - mov eax, stackdata - @@1: - mov edx, [eax] - push edx - sub eax, 4 - dec ecx - or ecx, ecx - jnz @@1 - @@2: - mov eax,_EAX - mov edx,_EDX - mov ecx,_ECX - call p - mov ecx, resultlength - cmp ecx, 0 - je @@5 - cmp ecx, 1 - je @@3 - cmp ecx, 2 - je @@4 - mov r, eax - jmp @@5 - @@3: - xor ecx, ecx - mov cl, al - mov r, ecx - jmp @@5 - @@4: - xor ecx, ecx - mov cx, ax - mov r, ecx - @@5: - mov ecx, resedx - jecxz @@6 - mov [ecx], edx - @@6: +{$IFDEF CPUX64} + + {$IFDEF DELPHI} + {$DEFINE REG_STACK_PTR_OFFSET0} { optional } // ! Successfully on exceptions ! + {$ENDIF} + + {$IFDEF FPC} + {$mode delphi} + {$ASMMODE INTEL} + {.$DEFINE REG_STACK_PTR_OFFSET0} { optional } // ! GPF on exceptions for both asm variants! + {$ENDIF} + +{$ENDIF CPUX64} + +{$IFDEF REG_STACK_PTR_OFFSET0} // ! NEW asm-win-x64 version for delphi and/or fpc ! + +procedure x64call({RCX}Address: Pointer;out {RDX}_RAX: IPointer;var {R8}_XMM0: Double; var {R9}RegInfo: TRegisters); +assembler; {$ifdef FPC}nostackframe;{$endif} + // + // !!! DELPHI: Successfully on exceptions ! + // !!! TODO: FPC: ! GPF on exception ! + // + procedure InvokeErrorParamCount; // The number of parameters exceeded 64 (c_par_max_count) + begin + raise EInvocationError.Create('Internal: Parameter count exceeded 64'); end; - Result := r; + // +const + c_par_max_count = 64; // == $40 + + c_sz_ptr = SizeOf(Pointer); // == 8 + c_arg_count = 4; // == 4 + c_arg_size = c_arg_count * c_sz_ptr; // == 32 + c_loc_count = c_par_max_count + 4; // == 68 + c_params = c_loc_count - c_arg_count + 1; // == 65 + + c_loc_offs_adress = c_loc_count * c_sz_ptr + c_arg_size; // == 576 + c_loc_offs__rax = c_loc_offs_adress + 1*c_sz_ptr; // == 584 + c_loc_offs__xmm0 = c_loc_offs_adress + 2*c_sz_ptr; // == 592 + c_loc_offs_reginfo = c_loc_offs_adress + 4*c_sz_ptr; // == 608 + + //c_reg_packed = ((SizeOf(TRegisters) mod c_sz_ptr) + c_sz_ptr - 1) div c_sz_ptr; // 1 - packed records; 0 - aligned +asm +{$ifdef DELPHI} + .params c_params // There's actually room for c_loc_count, assembler is saving locals for "Address,_RAX,_XMM0,RegInfo" +{$else} // TODO: FPC: GPF on exception + push rbp + sub rsp, $210 + mov rbp, rsp +{$endif} + + mov [rbp+c_loc_offs_adress], Address // save: rcx (@Address) + mov [rbp+c_loc_offs__rax], _RAX // save: rdx (@_RDX) + mov [rbp+c_loc_offs__xmm0], _XMM0 // save: r8 (@_XMM0) + mov [rbp+c_loc_offs_reginfo], RegInfo // save: r9 (@RegInfo) dbg: TRegisters(pointer(R9)^),r + + // + // check Registers.Items (param count limitation) + // + mov rcx, [RegInfo].TRegisters.Items + test rcx, rcx + jz @@skip_items + + cmp rcx, c_par_max_count-2 + jbe @@frame_is_try + + call InvokeErrorParamCount + +@@frame_is_try: + // + // copy registers: + // source : [RegInfo].TRegisters.Stack + // dest : [rbp + c_arg_count*c_sz_ptr] + // count : rcx + // note : All items on stack should be 16 byte aligned. Caller should have handled that, just copy data here. + // + mov r8, [RegInfo].TRegisters.Stack // source + lea rdx, [rbp + c_arg_count*c_sz_ptr] // dest +@copy_loop: + // copy pointer: + mov rax, [r8] + mov [rdx], rax + // next: + add r8, c_sz_ptr + add rdx, c_sz_ptr + dec rcx + or rcx, rcx + jnz @copy_loop + // next. + // + // copy registers. + +@@skip_items: + + // mov *, [r9].* ; [r9] == [RegInfo] + mov rcx, [RegInfo].TRegisters._RCX + mov rdx, [RegInfo].TRegisters._RDX + mov r8, [RegInfo].TRegisters._R8 + + movsd xmm0,[RegInfo].TRegisters._RCX + movsd xmm1,[RegInfo].TRegisters._RDX + movsd xmm2,[RegInfo].TRegisters._R8 + movsd xmm3,[RegInfo].TRegisters._R9 + + mov r9, [RegInfo].TRegisters._R9 // !!! Overwritten RegInfo (r9) + + call [rbp+c_loc_offs_adress] + + // make result + mov rdx, [rbp+c_loc_offs__rax] // restore: rdx (@_RDX) + mov [rdx], RAX // fill: _RAX + + //movsd [rdx+c_sz_ptr], XMM0 // fill: _XMM0 + mov rdx, [rbp+c_loc_offs__xmm0] // restore: r8 (@_RMM0) + mov [rdx], RAX // fill: _RAX + +{$ifdef DELPHI} +{$else} + lea rsp, [rbp+$210] + pop rbp + + ret +{$endif} end; -function RealCall_Other(p: Pointer; - StackData: Pointer; - StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes) - ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack -var - r: Longint; +{$ELSE !IFDEF REG_STACK_PTR_OFFSET0} // ! asm-win-x64 version for delphi and/or fpc ! + + {$undef _demo_x64call_gpf_} + {.$IFDEF DEBUG} + {.$define _demo_x64call_gpf_} { optional } + {.$ENDIF} + +{$ifdef _demo_x64call_gpf_} +procedure demo_x64call_gpf(); begin - asm - mov ecx, stackdatalen - jecxz @@2 - mov eax, stackdata - @@1: - mov edx, [eax] - push edx - sub eax, 4 - dec ecx - or ecx, ecx - jnz @@1 - @@2: - call p - mov ecx, resultlength - cmp ecx, 0 - je @@5 - cmp ecx, 1 - je @@3 - cmp ecx, 2 - je @@4 - mov r, eax - jmp @@5 - @@3: - xor ecx, ecx - mov cl, al - mov r, ecx - jmp @@5 - @@4: - xor ecx, ecx - mov cx, ax - mov r, ecx - @@5: - mov ecx, resedx - jecxz @@6 - mov [ecx], edx - @@6: - end; - Result := r; + raise Exception.Create('Demo x64 GPF!'); end; +{$endif} -function RealCall_CDecl(p: Pointer; - StackData: Pointer; - StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes) - ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack -var - r: Longint; -begin - asm - mov ecx, stackdatalen - jecxz @@2 - mov eax, stackdata - @@1: - mov edx, [eax] - push edx - sub eax, 4 - dec ecx - or ecx, ecx - jnz @@1 - @@2: - call p - mov ecx, resultlength - cmp ecx, 0 - je @@5 - cmp ecx, 1 - je @@3 - cmp ecx, 2 - je @@4 - mov r, eax - jmp @@5 - @@3: - xor ecx, ecx - mov cl, al - mov r, ecx - jmp @@5 - @@4: - xor ecx, ecx - mov cx, ax - mov r, ecx - @@5: - mov ecx, stackdatalen - jecxz @@7 - @@6: - pop eax - dec ecx - or ecx, ecx - jnz @@6 - mov ecx, resedx - jecxz @@7 - mov [ecx], edx - @@7: +procedure x64call( // TODO: ! GPF on exception ! + Address: Pointer; + out _RAX: IPointer; + var _XMM0: Double; + var Registers: TRegisters); assembler; {$IFDEF FPC}nostackframe;{$ENDIF} +asm +(* Registers: + RCX: Address + RDX: *_RAX + R8: * _XMM0 + R9: _REGISTERS + fpc inserts an 20h empty space +*) +//{$IFDEF FPC} + push rbp + mov rbp,rsp +//{$ENDIF} + push rcx // address ;rbp -8 + push rdx // @_rax ;rbp -16 + push r8 // @_xmm0 ;rbp -24 + push r9 // _registers ;rbp -32 + + mov rax, [rbp-32] //registers + + mov rcx, [rax+64] // items/count + mov rdx, [rax+56] // stack + jmp @compareitems +@work: +{$IFDEF FPC} + push qword ptr [rdx] +{$ELSE} + push [rdx] +{$ENDIF} + dec rcx + sub rdx,8 +@compareitems: + or rcx, rcx + jnz @work + + // copy registers + mov rcx, [rax+72] // single bits + + bt rcx, 1 + jnc @g1 + cvtsd2ss xmm1, [rax+32] + jmp @g1e + @g1: + movsd xmm1, [rax+32] + @g1e: + + bt rcx, 2 + jnc @g2 + cvtsd2ss xmm2, [rax+40] + jmp @g2e + @g2: + movsd xmm2, [rax+40] + @g2e: + + bt rcx, 3 + jnc @g3 + cvtsd2ss xmm3, [rax+48] + jmp @g3e + @g3: + movsd xmm3, [rax+48] + @g3e: + + // rbp-16: address of xmm0 + + bt rcx, 0 + jnc @g0 + mov rdx, [rbp -24] + cvtsd2ss xmm0, [rdx] + jmp @g0e + @g0: + mov rdx, [rbp -24] + movsd xmm0, [rdx] + @g0e: + + // other registers + mov rcx, [rax] + mov rdx, [rax+8] + mov r8, [rax+16] + mov r9, [rax+24] + + mov RAX, [rbp-8] + + // weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in + sub RSP, 32 + +{$ifdef _demo_x64call_gpf_} + // Demonstration GPF: + call demo_x64call_gpf +{$endif} + + call RAX + + add RSP, 32 // undo the damage done earlier + + // copy result back + mov RDX, [rbp-16] + mov [RDX], RAX + + mov rax, [rbp-32] //registers + + bt [rax+72], 8 // if atype.basetype <> btSingle + jnc @g5 // + cvtss2sd xmm1,xmm0 // convert single to double into xmm1 + mov rdx,[rbp-24] // @_xmm0 ;rbp -24 + movsd qword ptr [rdx], xmm1 // save xmm1 to param _xmm0 + jmp @g5e // exit if atype.basetype = btSingle + + @g5: //else "if atype.basetype = btSingle" + mov rdx,[rbp-24] // @_xmm0 ;rbp -24 + movsd qword ptr [rdx], xmm0 // save xmm1 to param _xmm0 + + @g5e: + + leave + ret +end; +{$ENDIF !IFDEF REG_STACK_PTR_OFFSET0} + +{$ELSE !WINDOWS} // ! Not windows version ! +type + //{$IFDEF UNICODE_OR_FPC}{$ALIGN 16}{$ENDIF} // For packed record mode + //{$ifdef FPC} + //{$PACKRECORDS 16} + //{$endif} + TRegisters = packed record + _RDI, // 0 + _RSI, // 8 + _RDX, // 16 + _RCX, // 24 + _R8, // 32 + _R9: IPointer; // 40 + _XMM1, // 48 + _XMM2, // 56 + _XMM3, // 64 + _XMM4, // 72 + _XMM5, // 80 + _XMM6, // 88 + _XMM7: Double; // 96 + SingleBits: Integer; //104 end; - Result := r; + +procedure x64call( // TODO: Need check GPF on exception ! + Address: Pointer; + out _RAX: IPointer; + var Registers: TRegisters; + aStack: Pointer; aItems: Integer; var _XMM0: Double); assembler; nostackframe; +asm +(* Registers: + RDI: Address + RSI: _RAX + RDX: Registers + RCX: aStack + R8: aItems + R9: XMM0 + + rbp-8 addr + rbp-16 _rax + rbp-24 _xmm0 + rbp-32 regs +*) + push rbp + mov rbp,rsp + push rdi // address + push rsi // _rax + push r9 // xmm0 + push rdx +{$IFDEF PS_STACKALIGN} + bt r8, 0 + jnc @skipjump + sub rsp, 8 +@skipjump: +{$ENDIF} + mov rax, rdx + jmp @compareitems +@work: +{$IFDEF FPC} + push qword ptr [rcx] +{$ELSE} + push [rcx] +{$ENDIF} + dec r8 + sub rcx,8 +@compareitems: + or r8, r8 + jnz @work + + // copy registers + // xmm0 + mov rdx,[rbp-24] + bt [rax+104], 0 + jnc @skipxmm0 + cvtsd2ss xmm0,[rdx] + jmp @skipxmm0re + @skipxmm0: + movq xmm0,[rdx] // move quadword to xmm0 from _XMM0 + @skipxmm0re: + + // xmm1 + bt [rax+104], 1 + jnc @skipxmm1 + cvtsd2ss xmm1,[rax+48] + jmp @skipxmm1re + @skipxmm1: + movq xmm1,[rax+48] // move quadword to xmm1 from Registers._XMM1 + @skipxmm1re: + + // xmm2 + bt [rax+104], 2 + jnc @skipxmm2 + cvtsd2ss xmm2,[rax+56] + jmp @skipxmm2re + @skipxmm2: + movq xmm2,[rax+56] // move quadword to xmm2 from Registers._XMM2 + @skipxmm2re: + + // xmm3 + bt [rax+104], 3 + jnc @skipxmm3 + cvtsd2ss xmm3,[rax+64] + jmp @skipxmm3re + @skipxmm3: + movq xmm3,[rax+64] // move quadword to xmm3 from Registers._XMM3 + @skipxmm3re: + + // xmm4 + bt [rax+104], 4 + jnc @skipxmm4 + cvtsd2ss xmm4,[rax+72] + jmp @skipxmm4re + @skipxmm4: + movq xmm4,[rax+72] // move quadword to xmm4 from Registers._XMM4 + @skipxmm4re: + + // xmm5 + bt [rax+104], 5 + jnc @skipxmm5 + cvtsd2ss xmm5,[rax+80] + jmp @skipxmm5re + @skipxmm5: + movq xmm5,[rax+80] // move quadword to xmm5 from Registers._XMM5 + @skipxmm5re: + + // xmm6 + bt [rax+104], 6 + jnc @skipxmm6 + cvtsd2ss xmm6,[rax+88] + jmp @skipxmm6re + @skipxmm6: + movq xmm6,[rax+88] // move quadword to xmm6 from Registers._XMM6 + @skipxmm6re: + + // xmm7 + bt [rax+104], 7 + jnc @skipxmm7 + cvtsd2ss xmm7,[rax+96] + jmp @skipxmm7re + @skipxmm7: + movq xmm7,[rax+96] // move quadword to xmm7 from Registers._XMM7 + @skipxmm7re: + + mov RDI, [rax] + mov RSI, [rax+ 8] + mov RDX, [rax+16] + mov RCX, [rax+24] + mov R8, [rax+32] + mov R9, [rax+40] + + // weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in; not sure about linux + //sub RSP, 32 + + mov rax, [rbp-8] + call RAX + + // add rsp, 8 + + // add rsp, 32 // undo the damage done earlier + + // copy result back + mov rsi, [rbp-16] // _RAX parameter + mov [rsi], RAX + mov rsi, [rbp-24] // _XMM0 parameter + + // xmm0 res + mov rax, [rbp-32] // Registers parameter + bt [rax+104], 8 // if atype.basetype <> btSingle + jnc @skipres // then goto skipres else begin + cvtss2sd xmm1,xmm0 // convert single to double into xmm1 + movq [rsi],xmm1 // move quadword to _XMM0 + jmp @skipresre // end + @skipres: + movq [rsi],xmm0 // move quadword to _XMM0 + @skipresre: + + pop rdx + pop r9 // xmm0 + pop rsi // _rax + pop rdi // address + leave + ret end; +{$ENDIF !WINDOWS} -const - EmptyPchar: array[0..0] of char = #0; +{$ENDIF X64CALL_ASM} function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean; var - Stack: ansistring; - I: Longint; - RegUsage: Byte; - CallData: TPSList; - pp: ^Byte; + Stack: array of Byte; + _RAX: IPointer; + _XMM0: Double; + Registers: TRegisters; + {$IFNDEF WINDOWS} + RegUsageFloat: Byte; + {$ENDIF} {$IFDEF FPC} IsConstructor,IsVirtualCons: Boolean; - MethodData: TMethod; {$ENDIF} - - EAX, EDX, ECX: Longint; + RegUsage: Byte; + CallData: TPSList; + I: Integer; + pp: ^Byte; function rp(p: PPSVariantIFC): PPSVariantIFC; begin - if p = nil then - begin + if (p = nil) or (p.aType = nil) then begin result := nil; exit; end; - if p.aType.BaseType = btPointer then - begin - p^.aType := Pointer(Pointer(IPointer(p^.dta) + 4)^); + if p.aType.BaseType = btPointer then begin + p^.aType := Pointer(Pointer(IPointer(p^.dta) + PointerSize)^); p^.Dta := Pointer(p^.dta^); end; Result := p; end; + {$IFDEF WINDOWS} + procedure StoreReg(data: IPointer); overload; + var p: Pointer; + begin + case RegUsage of + 0: begin inc(RegUsage); Registers._RCX:=Data; end; + 1: begin inc(RegUsage); Registers._RDX:=Data; end; + 2: begin inc(RegUsage); Registers._R8:=Data; end; + 3: begin inc(RegUsage); Registers._R9:=Data; end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[Length(Stack)-8]; + IPointer(p^) := data; + end; + end; + end; + {$ELSE !WINDOWS} + procedure StoreReg(data: IPointer); overload; + var p: Pointer; + begin + case RegUsage of + 0: begin inc(RegUsage); Registers._RDI:=Data; end; + 1: begin inc(RegUsage); Registers._RSI:=Data; end; + 2: begin inc(RegUsage); Registers._RDX:=Data; end; + 3: begin inc(RegUsage); Registers._RCX:=Data; end; + 4: begin inc(RegUsage); Registers._R8:=Data; end; + 5: begin inc(RegUsage); Registers._R9:=Data; end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[Length(Stack)-8]; + IPointer(p^) := data; + end; + end; + end; + {$ENDIF !WINDOWS} + + procedure StoreStack(const aData; Len: Integer); + var + p: Pointer; + begin + if Len > 8 then + if Length(Stack) mod 16 <> 0 then begin + SetLength(Stack, Length(Stack)+ (16-(Length(Stack) mod 16))); + end; + SetLength(Stack, Length(Stack)+Len); + p := @Stack[Length(Stack)-Len]; + Move(aData, p^, Len); + end; + + {$IFDEF WINDOWS} + procedure StoreReg(data: Double); overload; + var p: Pointer; + begin + case RegUsage of + 0: begin inc(RegUsage); _XMM0:=Data; end; + 1: begin inc(RegUsage); Registers._XMM1:=Data; end; + 2: begin inc(RegUsage); Registers._XMM2:=Data; end; + 3: begin inc(RegUsage); Registers._XMM3:=Data; end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[Length(Stack)-8]; + Double(p^) := data; + end; + end; + end; + procedure StoreReg(data: Single); overload; + var p: Pointer; + begin + case RegUsage of + 0: begin inc(RegUsage); Registers.SingleBits := Registers.SingleBits or 1;_XMM0:=Data; end; + 1: begin inc(RegUsage); Registers.SingleBits := Registers.SingleBits or 2; Registers._XMM1:=Data; end; + 2: begin inc(RegUsage); Registers.SingleBits := Registers.SingleBits or 4;Registers._XMM2:=Data; end; + 3: begin inc(RegUsage); Registers.SingleBits := Registers.SingleBits or 8; Registers._XMM3:=Data; end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[Length(Stack)-8]; + Double(p^) := data; + end; + end; + end; + {$ELSE !WINDOWS} + procedure StoreReg(data: Double); overload; + var p: Pointer; + begin + case RegUsageFloat of + 0: begin inc(RegUsageFloat); _XMM0:=Data; end; + 1: begin inc(RegUsageFloat); Registers._XMM1:=Data; end; + 2: begin inc(RegUsageFloat); Registers._XMM2:=Data; end; + 3: begin inc(RegUsageFloat); Registers._XMM3:=Data; end; + 4: begin inc(RegUsageFloat); Registers._XMM4:=Data; end; + 5: begin inc(RegUsageFloat); Registers._XMM5:=Data; end; + 6: begin inc(RegUsageFloat); Registers._XMM6:=Data; end; + 7: begin inc(RegUsageFloat); Registers._XMM7:=Data; end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[Length(Stack)-8]; + Double(p^) := data; + end; + end; + end; + procedure StoreReg(data: Single); overload; + var p: Pointer; + begin + case RegUsageFloat of + 0: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 1; _XMM0:=Data; end; + 1: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 2; Registers._XMM1:=Data; end; + 2: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 4; Registers._XMM2:=Data; end; + 3: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 8; Registers._XMM3:=Data; end; + 4: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 16; Registers._XMM4:=Data; end; + 5: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 32; Registers._XMM5:=Data; end; + 6: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 64; Registers._XMM6:=Data; end; + 7: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 128; Registers._XMM7:=Data; end; + else begin + SetLength(Stack, Length(Stack)+8); + p := @Stack[Length(Stack)-8]; + Double(p^) := data; + end; + end; + end; + {$ENDIF !WINDOWS} + + type + TMethodCallData = record + AType: Byte; + Data: TMethod; + end; + PMethodCallData=^TMethodCallData; function GetPtr(fVar: PPSVariantIFC): Boolean; var varPtr: Pointer; - UseReg: Boolean; - tempstr: tbtstring; p: Pointer; begin Result := False; - if FVar = nil then exit; + if fVar = nil then exit; if fVar.VarParam then begin - case fvar.aType.BaseType of - btArray: - begin - if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then - begin - p := CreateOpenArray(True, Self, FVar); + case fVar.aType.BaseType of + btArray: begin + if Copy(fVar.aType.ExportName, 1, 10) = '!OPENARRAY' then begin + p := CreateOpenArray(True, Self, fVar); if p = nil then exit; + if CallData = nil then + CallData := TPSList.Create; CallData.Add(p); - case RegUsage of - 0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; - 1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; - 2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; - else begin - Stack := StringOfChar(AnsiChar(#0),4) + Stack; - Pointer((@Stack[1])^) := POpenArray(p)^.Data; - end; - end; - case RegUsage of - 0: begin EAX := Longint(POpenArray(p)^.ItemCount - 1); Inc(RegUsage); end; - 1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; - 2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; - else begin - Stack := StringOfChar(AnsiChar(#0),4) + Stack; - Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1; - end; - end; + StoreReg(IPointer(POpenArray(p)^.Data)); + StoreReg(IPointer(POpenArray(p)^.ItemCount -1)); Result := True; Exit; end else begin - {$IFDEF PS_DYNARRAY} - varptr := fvar.Dta; - {$ELSE} - Exit; - {$ENDIF} + varptr := fVar.Dta; + //Exit; end; end; btVariant, @@ -326,190 +1124,105 @@ var btRecord, btInterface, btClass, - {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16, + {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar,{$ENDIF} btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency - {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: - begin - Varptr := fvar.Dta; + {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: begin + Varptr := fVar.Dta; end; - else begin - exit; //invalid type - end; - end; {case} - case RegUsage of - 0: begin EAX := Longint(VarPtr); Inc(RegUsage); end; - 1: begin EDX := Longint(VarPtr); Inc(RegUsage); end; - 2: begin ECX := Longint(VarPtr); Inc(RegUsage); end; else begin - Stack := StringOfChar(AnsiChar(#0),4) + Stack; - Pointer((@Stack[1])^) := VarPtr; + Exit; // invalid type end; - end; - end else begin - UseReg := True; - case fVar^.aType.BaseType of - btSet: - begin - tempstr := StringOfChar(AnsiChar(#0),4); - case TPSTypeRec_Set(fvar.aType).aByteSize of - 1: Byte((@tempstr[1])^) := byte(fvar.dta^); - 2: word((@tempstr[1])^) := word(fvar.dta^); - 3, 4: cardinal((@tempstr[1])^) := cardinal(fvar.dta^); + end; {case} + StoreReg(IPointer(VarPtr)); + end else begin { #else : (not fVar.VarParam) } + case fVar.aType.BaseType of + btSet: begin + case TPSTypeRec_Set(fVar.aType).aByteSize of + 1: StoreReg(IPointer(byte(fVar.dta^))); + 2: StoreReg(IPointer(word(fVar.dta^))); + 3, 4: StoreReg(IPointer(cardinal(fVar.dta^))); + 5,6,7,8: StoreReg(IPointer(fVar.Dta^)); else - pointer((@tempstr[1])^) := fvar.dta; + StoreReg(IPointer(fVar.Dta)); end; end; - btArray: - begin - if Copy(fvar^.aType.ExportName, 1, 10) = '!OPENARRAY' then - begin - p := CreateOpenArray(False, SElf, FVar); + btArray: begin + if Copy(fVar.aType.ExportName, 1, 10) = '!OPENARRAY' then begin + p := CreateOpenArray(False, Self, fVar); if p =nil then exit; + if CallData = nil then + CallData := TPSList.Create; CallData.Add(p); - case RegUsage of - 0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; - 1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; - 2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; - else begin - Stack := StringOfChar(AnsiChar(#0),4) + Stack; - Pointer((@Stack[1])^) := POpenArray(p)^.Data; - end; - end; - case RegUsage of - 0: begin EAX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; - 1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; - 2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; - else begin - Stack := StringOfChar(AnsiChar(#0),4) + Stack; - Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1; - end; - end; + StoreReg(IPointer(POpenArray(p)^.Data)); + StoreReg(IPointer(POpenArray(p)^.ItemCount -1)); Result := True; exit; end else begin - {$IFDEF PS_DYNARRAY} - TempStr := StringOfChar(AnsiChar(#0),4); - Pointer((@TempStr[1])^) := Pointer(fvar.Dta^); - {$IFDEF PS_ARRAY_ON_STACK} - UseReg := false; - {$ENDIF} - {$ELSE} - Exit; - {$ENDIF} + StoreReg(IPointer(fVar.Dta{$IFNDEF FPC}^{$ENDIF})); end; end; - btVariant - , btStaticArray, btRecord: - begin - TempStr := StringOfChar(AnsiChar(#0),4); - Pointer((@TempStr[1])^) := Pointer(fvar.Dta); + btRecord: begin + if fVar.aType.RealSize <= sizeof(IPointer) then + StoreReg(IPointer(fVar.dta^)) + else + StoreReg(IPointer(fVar.Dta)); end; - btDouble: {8 bytes} begin - TempStr := StringOfChar(AnsiChar(#0),8); - UseReg := False; - double((@TempStr[1])^) := double(fvar.dta^); + btVariant, btStaticArray: begin + StoreReg(IPointer(fVar.Dta)); + end; + btExtended, btDouble: {8 bytes} begin + StoreReg(double(fVar.dta^)); end; btCurrency: {8 bytes} begin - TempStr := StringOfChar(AnsiChar(#0),8); - UseReg := False; - currency((@TempStr[1])^) := currency(fvar.dta^); + StoreReg(IPointer(fVar.dta^)); end; btSingle: {4 bytes} begin - TempStr := StringOfChar(AnsiChar(#0),4);; - UseReg := False; - Single((@TempStr[1])^) := single(fvar.dta^); + StoreReg(single(fVar.dta^)); end; - btExtended: {10 bytes} begin - UseReg := False; - TempStr:= StringOfChar(AnsiChar(#0),12); - Extended((@TempStr[1])^) := extended(fvar.dta^); - end; - btChar, - btU8, - btS8: begin - TempStr := tbtchar(fVar^.dta^) + tbtstring(StringOfChar(AnsiChar(#0),3)); + btChar, btU8, btS8: begin + StoreReg(IPointer(byte(fVar.dta^))); end; - {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF} - btu16, btS16: begin - TempStr := StringOfChar(AnsiChar(#0),4); - Word((@TempStr[1])^) := word(fVar^.dta^); + btWideChar, + btU16, btS16: begin + StoreReg(IPointer(word(fVar.dta^))); end; - btu32, bts32: begin - TempStr := StringOfChar(AnsiChar(#0),4); - Longint((@TempStr[1])^) := Longint(fVar^.dta^); + btU32, btS32: begin + StoreReg(IPointer(cardinal(fVar.dta^))); end; - btPchar: - begin - TempStr := StringOfChar(AnsiChar(#0),4); - if pointer(fvar^.dta^) = nil then - Pointer((@TempStr[1])^) := @EmptyPchar + btPChar: begin + if Pointer(fVar.dta^) = nil then + StoreReg(IPointer(@EmptyPChar)) else - Pointer((@TempStr[1])^) := pointer(fvar^.dta^); + StoreReg(IPointer(fVar.dta^)); end; - btclass, btinterface, btString: - begin - TempStr := StringOfChar(AnsiChar(#0),4); - Pointer((@TempStr[1])^) := pointer(fvar^.dta^); + btClass, btInterface, btString: begin + StoreReg(IPointer(fVar.dta^)); end; - {$IFNDEF PS_NOWIDESTRING} btWideString: begin - TempStr := StringOfChar(AnsiChar(#0),4); - Pointer((@TempStr[1])^) := pointer(fvar^.dta^); + StoreReg(IPointer(fVar.dta^)); end; btUnicodeString: begin - TempStr := StringOfChar(AnsiChar(#0),4); - Pointer((@TempStr[1])^) := pointer(fvar^.dta^); + StoreReg(IPointer(fVar.dta^)); end; - {$ENDIF} - - btProcPtr: - begin -{$IFDEF FPC} - MethodData := MKMethod(Self, Longint(FVar.Dta^)); - TempStr := StringOfChar(AnsiChar(#0),4); - Pointer((@TempStr[1])^) := @MethodData; -{$ELSE} - TempStr := StringOfChar(AnsiChar(#0),8); - TMethod((@TempStr[1])^) := MKMethod(Self, Longint(FVar.Dta^)); - UseReg := false; -{$ENDIF} + btProcPtr: begin + p := New(PMethodCallData); + TMethodCallData(p^).AType:=255; + if CallData = nil then + CallData := TPSList.Create; + CallData.Add(p); + TMethodCallData(p^).Data := MKMethod(Self, Longint(fVar.Dta^)); // It requires the implementation of "Handled" + StoreReg(IPointer(@TMethodCallData(p^).Data)); end; - - {$IFNDEF PS_NOINT64}bts64: - begin - TempStr:= StringOfChar(AnsiChar(#0),8); - Int64((@TempStr[1])^) := int64(fvar^.dta^); - UseReg := False; - end;{$ENDIF} - end; {case} - if UseReg then - begin - case RegUsage of - 0: begin EAX := Longint((@Tempstr[1])^); Inc(RegUsage); end; - 1: begin EDX := Longint((@Tempstr[1])^); Inc(RegUsage); end; - 2: begin ECX := Longint((@Tempstr[1])^); Inc(RegUsage); end; - else begin - {$IFDEF FPC_OLD_FIX} - if CallingConv = cdRegister then - Stack := Stack + TempStr - else - {$ENDIF} - Stack := TempStr + Stack; + btS64: begin + StoreReg(IPointer(int64(fVar.dta^))); end; - end; - end else begin - {$IFDEF FPC_OLD_FIX} - if CallingConv = cdRegister then - Stack := Stack + TempStr - else - {$ENDIF} - Stack := TempStr + Stack; - end; - end; + end; {case} + end; { #if else : (not fVar.VarParam) } Result := True; - end; -begin + end; // function GetPtr + +begin // function TPSExec.InnerfuseCall {$IFDEF FPC} if (Integer(CallingConv) and 128) <> 0 then begin IsVirtualCons := true; @@ -525,260 +1238,183 @@ begin InnerfuseCall := False; if Address = nil then exit; // need address - Stack := ''; - CallData := TPSList.Create; + SetLength(Stack, 0); + CallData := nil; res := rp(res); if res <> nil then res.VarParam := true; try - case CallingConv of - cdRegister: begin - EAX := 0; - EDX := 0; - ECX := 0; - RegUsage := 0; - -{$IFDEF FPC} // FIX FOR FPC constructor calls - if IsConstructor then begin - if not GetPtr(rp(Params[0])) then exit; // this goes first - RegUsage := 2; - EDX := Longint(_Self); - DisposePPSVariantIFC(Params[0]); - Params.Delete(0); - end else +{$IFNDEF WINDOWS} + (*_RSI := 0; + _RDI := 0; + _XMM4 := 0; + _XMM5 := 0; + _XMM6 := 0; + _XMM7 := 0;*) + RegUsageFloat := 0; {$ENDIF} - if assigned(_Self) then begin - RegUsage := 1; - EAX := Longint(_Self); + _XMM0 := 0; + FillChar(Registers, Sizeof(Registers), 0); + _RAX := 0; + RegUsage := 0; + {$warnings off} + {$IF DEFINED (fpc) and (fpc_version >= 3)} // FIX FOR FPC constructor calls + {$warnings on} + if IsConstructor then begin + if not GetPtr(rp(Params[0])) then exit; // this goes first + DisposePPSVariantIFC(Params[0]); + Params.Delete(0); + end; + {$ENDIF} + if assigned(_Self) then begin + StoreReg(IPointer(_Self)); + end; + if assigned(res) and (res^.atype.basetype = btSingle) then begin + Registers.Singlebits := Registers.Singlebits or 256; + end; + {$IFDEF PS_RESBEFOREPARAMETERS} + if assigned(res) then begin + case res^.aType.BaseType of + {$IFDEF x64_string_result_as_varparameter} + {$IFNDEF PS_NOWIDESTRING} + btWideString, btUnicodeString, + {$ENDIF} + {.$IFNDEF PS_FPCSTRINGWORKAROUND} + btString, + {.$ENDIF} + {$ENDIF x64_string_result_as_varparameter} + btInterface, btArray, btVariant, btStaticArray: + GetPtr(res); + btRecord, + btSet: + begin + if res.aType.RealSize > PointerSize then + GetPtr(res); end; - - for I := 0 to Params.Count - 1 do + end; + end; + {$ENDIF PS_RESBEFOREPARAMETERS} + for I := 0 to Params.Count - 1 do begin + if not GetPtr(rp(Params[I])) then + Exit; + end; + if assigned(res) then begin + {$IFNDEF PS_RESBEFOREPARAMETERS} + case res^.aType.BaseType of + {$IFDEF x64_string_result_as_varparameter} + btstring, btWideString, btUnicodeString, + {$ENDIF} + btInterface, btArray, btVariant, btStaticArray: + GetPtr(res); + btRecord, + btSet: begin - if not GetPtr(rp(Params[I])) then Exit; + if res.aType.RealSize > PointerSize then + GetPtr(res); end; + end; + {$ENDIF !PS_RESBEFOREPARAMETERS} + {$IFDEF WINDOWS} + if (length(Stack) mod 16) <> 0 then begin + SetLength(Stack, Length(Stack)+16 - (Length(Stack) mod 16)); + end; + {$ENDIF} + if Stack = nil + then pp := nil + else pp := @Stack[{$IFDEF REG_STACK_PTR_OFFSET0}0{$ELSE}Length(Stack)-8{$ENDIF}]; - if assigned(res) then begin - case res^.aType.BaseType of - {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF} - btInterface, {$IFNDEF FPC} btArray, {$ENDIF}btrecord, {$IFNDEF PS_FPCSTRINGWORKAROUND}btstring, {$ENDIF}btVariant, btStaticArray: GetPtr(res); - btSet: - begin - if TPSTypeRec_Set(res.aType).aByteSize >4 then GetPtr(res); - end; - end; - {$IFDEF DARWIN} - if (length(Stack) mod 16) <> 0 then begin - Stack := Stack + StringOfChar(ansichar(#32), 16 - (Length(Stack) mod 16)) ; - end; - {$ENDIF} - case res^.aType.BaseType of - btSet: - begin - case TPSTypeRec_Set(res.aType).aByteSize of - 1: byte(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); - 2: word(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); - 3, - 4: Longint(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); - else RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil) - end; - end; - btSingle: tbtsingle(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4); - btDouble: tbtdouble(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4); - btExtended: tbtextended(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4); - btchar,btU8, btS8: tbtu8(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); - {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); - btClass : - begin - {$IF DEFINED (fpc) and (fpc_version < 3)} - if IsConstructor or IsVirtualCons then - tbtu32(res.dta^) := RealCall_Register(Address, EDX, EAX, ECX, - @Stack[Length(Stack) - 3], Length(Stack) div 4, 4, nil) - else - {$IFEND} - tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, - @Stack[Length(Stack) - 3], Length(Stack) div 4, 4, nil); - end; - - btu32,bts32{$IFDEF FPC},btArray{$ENDIF}: tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); - btPChar: pansichar(res.dta^) := Pansichar(RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); - {$IFNDEF PS_NOINT64}bts64: - begin - EAX := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); - tbts64(res.dta^) := Int64(Cardinal(EDX)) shl 32 or Cardinal(EAX); - end; - {$ENDIF} - btCurrency: tbtCurrency(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4) / 10000; - btInterface, - btVariant, - {$IFNDEF PS_NOWIDESTRING}btWidestring,btUnicodestring, {$ENDIF} - btStaticArray, {$IFNDEF FPC} btArray,{$ENDIF} btrecord{$IFNDEF PS_FPCSTRINGWORKAROUND}, btstring {$ENDIF}: RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); - {$IFDEF PS_FPCSTRINGWORKAROUND} - btstring: begin - eax := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); - Longint(res.dta^) := eax; - end; - {$ENDIF} - else - exit; - end; - end else begin - {$IFDEF DARWIN} - if (length(Stack) mod 16) <> 0 then begin - Stack := Stack + StringOfChar(ansichar(#32), 16 - (Length(Stack) mod 16)) ; - end; - {$ENDIF} - RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); - end; - Result := True; - end; - cdPascal: begin - RegUsage := 3; - for I := 0 to Params.Count - 1 do begin - if not GetPtr(Params[i]) then Exit; - end; - if assigned(res) then begin - case res^.aType.BaseType of - {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF}btInterface, btArray, btrecord, btstring, btVariant: GetPtr(res); - end; - end; - if assigned(_Self) then begin - Stack := StringOfChar(AnsiChar(#0),4) +Stack; - Pointer((@Stack[1])^) := _Self; - end; - {$IFDEF DARWIN} - if (length(Stack) mod 16) <> 0 then begin - Stack := Stack + StringOfChar(ansichar(#32), 16 - (Length(Stack) mod 16)) ; - end; - {$ENDIF} - if assigned(res) then begin - case res^.aType.BaseType of - btSingle: tbtsingle(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); - btDouble: tbtdouble(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); - btExtended: tbtextended(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); - btChar, btU8, btS8: tbtu8(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); - {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); - btClass, btu32, bts32: tbtu32(res^.Dta^):= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); - btPChar: pansichar(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); - {$IFNDEF PS_NOINT64}bts64: - begin - EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); - tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX; - end; - {$ENDIF} - btVariant, - btInterface, btrecord, btstring: RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); - else - exit; - end; - end else - RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); - Result := True; - end; - cdSafeCall: begin - RegUsage := 3; - if assigned(res) then begin - GetPtr(res); - end; - for I := Params.Count - 1 downto 0 do begin - if not GetPtr(Params[i]) then Exit; - end; - if assigned(_Self) then begin - Stack := StringOfChar(AnsiChar(#0),4) +Stack; - Pointer((@Stack[1])^) := _Self; - end; - {$IFDEF DARWIN} - if (length(Stack) mod 16) <> 0 then begin - Stack := Stack + StringOfChar(ansichar(#32), 16 - (Length(Stack) mod 16)) ; - end; - {$ENDIF} - OleCheck(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); - Result := True; - end; + {$IFDEF WINDOWS} + Registers.Stack := pp; + Registers.Items := Length(Stack) div 8; + x64call(Address, _RAX, _XMM0, Registers); + {$ELSE} + x64call(Address, _RAX, Registers, pp, Length(Stack) div 8, _XMM0); + {$ENDIF !WINDOWS} - CdCdecl: begin - RegUsage := 3; - if assigned(_Self) then begin - Stack := StringOfChar(AnsiChar(#0),4); - Pointer((@Stack[1])^) := _Self; - end; - for I := Params.Count - 1 downto 0 do begin - if not GetPtr(Params[I]) then Exit; - end; - {$IFDEF DARWIN} - if (length(Stack) mod 16) <> 0 then begin - Stack := Stack + StringOfChar(ansichar(#32), 16 - (Length(Stack) mod 16)) ; - end; - {$ENDIF} - if assigned(res) then begin - case res^.aType.BaseType of - btSingle: tbtsingle(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); - btDouble: tbtdouble(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); - btExtended: tbtextended(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); - btCHar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); - {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); - btClass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); - btPChar: pansichar(res^.dta^) := Pansichar(RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); - {$IFNDEF PS_NOINT64}bts64: - begin - EAX := RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); - tbts64(res^.Dta^) := Int64(EAX) shl 32 or EDX; - end; - {$ENDIF} - btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF} - btInterface, - btArray, btrecord, btstring: begin GetPtr(res); RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end; - else - exit; + case res^.aType.BaseType of + btRecord, btSet: + begin + case res.aType.RealSize of + 1: byte(res.Dta^) := _RAX; + 2: word(res.Dta^) := _RAX; + 3, + 4: Longint(res.Dta^) := _RAX; + 5,6,7,8: IPointer(res.dta^) := _RAX; end; - end else begin - RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); - end; - Result := True; - end; - CdStdCall: begin - RegUsage := 3; - for I := Params.Count - 1 downto 0 do begin - if not GetPtr(Params[I]) then exit; end; - if assigned(_Self) then begin - Stack := StringOfChar(AnsiChar(#0),4) + Stack; - Pointer((@Stack[1])^) := _Self; + btSingle: + tbtsingle(res.Dta^) := _XMM0; + btDouble: + tbtdouble(res.Dta^) := _XMM0; + btExtended: + tbtextended(res.Dta^) := _XMM0; + btChar, btU8, btS8: + tbtu8(res.dta^) := _RAX; + + {$IFNDEF PS_NOWIDESTRING} + btWideChar, + {$ENDIF} + btu16, bts16: tbtu16(res.dta^) := _RAX; + + btClass : + IPointer(res.dta^) := _RAX; + btu32, bts32: + tbtu32(res.dta^) := _RAX; + btPChar: + pansichar(res.dta^) := Pansichar(_RAX); + bts64: + tbts64(res.dta^) := Int64(_RAX); + btCurrency: + tbtCurrency(res.Dta^) := Int64(_RAX); + + btInterface, + btVariant, + {$IFDEF x64_string_result_as_varparameter} + btWidestring, btUnicodestring, btString, + {$ENDIF} + btStaticArray, btArray:; + + {$IFNDEF x64_string_result_as_varparameter} + btUnicodeString, btWideString, btstring: + Int64(res.dta^) := _RAX; + {$ENDIF} + else + exit; + end; // case + end else begin // when res==nil + {$IFDEF WINDOWS} + if (length(Stack) mod 16) <> 0 then begin + SetLength(Stack, Length(Stack)+16 - (Length(Stack) mod 16)); + end; + {$ENDIF} + if Stack = nil + then pp := nil + else pp := @Stack[{$IFDEF REG_STACK_PTR_OFFSET0}0{$ELSE}Length(Stack)-8{$ENDIF}]; + + {$IFDEF WINDOWS} + Registers.Stack := pp; + Registers.Items := Length(Stack) div 8; + x64call(Address, _RAX, _XMM0, Registers); + {$ELSE} + x64call(Address, _RAX, Registers, pp, Length(Stack) div 8, _XMM0); + {$ENDIF !WINDOWS} + end; // if else + Result := True; + finally + if Assigned(CallData) then begin + for i := CallData.Count-1 downto 0 do + begin + pp := CallData[i]; + case pp^ of + 0: begin + DestroyOpenArray(Self, Pointer(pp)); end; - if assigned(res) then begin - case res^.aType.BaseType of - btSingle: tbtsingle(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); - btDouble: tbtdouble(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); - btExtended: tbtextended(res^.dta^):= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); - btChar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); - {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); - btclass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); - btPChar: pansichar(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); - {$IFNDEF PS_NOINT64}bts64: - begin - EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); - tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX; - end; - {$ENDIF} - btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF} - btInterface, btArray, btrecord, btstring: begin GetPtr(res); RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end; - else - exit; - end; - end else begin - RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + 255: begin + Dispose(PMethodCallData(pp)); // release TMethodCallData end; - Result := True; end; - end; - finally - for i := CallData.Count -1 downto 0 do - begin - pp := CallData[i]; - case pp^ of - 0: DestroyOpenArray(Self, Pointer(pp)); end; + CallData.Free; end; - CallData.Free; end; end; - From 05f7d9f20faf27fdc897ac7b22c10bd2a667a36b Mon Sep 17 00:00:00 2001 From: Vadim Lou Date: Sat, 2 Mar 2019 09:44:30 +0200 Subject: [PATCH 4/9] undo --- Source/x86.inc | 1957 ++++++++++++++++-------------------------------- 1 file changed, 660 insertions(+), 1297 deletions(-) diff --git a/Source/x86.inc b/Source/x86.inc index 27eff2a9..5475ba05 100644 --- a/Source/x86.inc +++ b/Source/x86.inc @@ -1,1121 +1,323 @@ -{ x64.inc } - -{.$O-,D+,L+} // for debug - -{$IFDEF DELPHI} - {$DEFINE PS_RESBEFOREPARAMETERS} - {$DEFINE x64_string_result_as_varparameter} -{$ENDIF} - -{ implementation of x64 abi } -//procedure DebugBreak; external 'Kernel32.dll'; -const - EmptyPChar: array[0..0] of Char = (Char(#0)); - -type - EInvocationError = class(Exception); - -// -// Calculate/Declare defines -// -{$UNDEF X64CALL_ASM} { not change } -{$UNDEF REG_STACK_PTR_OFFSET0} { not change } -{$IFDEF MSWINDOWS}{$DEFINE WINDOWS}{$ENDIF} - -{$IFDEF MSWINDOWS} - {$IFDEF CPUX64} - - {$IFDEF DELPHI} - {$DEFINE X64CALL_ASM} { optional } // ! Successfully on exceptions ! - {$ENDIF} - - {$IFDEF FPC} - {.$DEFINE X64CALL_ASM} { optional } // ! Not recomended : GPF on exception ! - {$ENDIF} - - {$ELSE} - - {$ENDIF} -{$ELSE !MSWINDOWS} - - {$DEFINE X64CALL_ASM} { optional } // TODO: Check pas version (disable "X64CALL_ASM"). - -{$ENDIF !MSWINDOWS} - -{$IFNDEF X64CALL_ASM} // PURE PASCAL version. ! DELPHI/FPC: Successfully on exceptions ! -type - {$IFDEF CPUX64} - t_pstask = array[0..61] of IPointer; - p_pstask = ^t_pstask; - TRegisters = packed record - _RCX, // 0 - _RDX, // 8 - _R8, // 16 - _R9: IPointer; // 24 - _XMM1, // 32 - _XMM2, // 40 - _XMM3: Double; // 48 - case byte of - 0:( - Stack: Pointer; // 56 - Items: {$IFDEF FPC}PtrUInt{$ELSE}IntPtr{$ENDIF}; // 64 - SingleBits: Integer; // 72 - ); - 1:(S: p_pstask); - end; - {$ENDIF CPUX64} - {$DEFINE REG_STACK_PTR_OFFSET0} { not change } -type - t_pcall_04 = procedure(_rcx,_rdx,_r8,_r9: IPointer); - t_pcall_05 = procedure(_rcx,_rdx,_r8,_r9,p5: IPointer); - t_pcall_06 = procedure(_rcx,_rdx,_r8,_r9,p5,p6: IPointer); - t_pcall_07 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7: IPointer); - t_pcall_08 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8: IPointer); - t_pcall_09 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9: IPointer); - t_pcall_10 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10: IPointer); - t_pcall_11 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11: IPointer); - t_pcall_12 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12: IPointer); - t_pcall_13 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13: IPointer); - t_pcall_14 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14: IPointer); - t_pcall_15 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15: IPointer); - t_pcall_16 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16: IPointer); - t_pcall_17 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17: IPointer); - t_pcall_18 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18: IPointer); - t_pcall_19 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19: IPointer); - t_pcall_20 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20: IPointer); - t_pcall_21 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21: IPointer); - t_pcall_22 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22: IPointer); - t_pcall_23 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23: IPointer); - t_pcall_24 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24: IPointer); - t_pcall_25 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25: IPointer); - t_pcall_26 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26: IPointer); - t_pcall_27 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27: IPointer); - t_pcall_28 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28: IPointer); - t_pcall_29 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29: IPointer); - t_pcall_30 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30: IPointer); - t_pcall_31 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31: IPointer); - t_pcall_32 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32: IPointer); - t_pcall_33 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33: IPointer); - t_pcall_34 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34: IPointer); - t_pcall_35 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35: IPointer); - t_pcall_36 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36: IPointer); - t_pcall_37 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37: IPointer); - t_pcall_38 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38: IPointer); - t_pcall_39 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39: IPointer); - t_pcall_40 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40: IPointer); - t_pcall_41 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41: IPointer); - t_pcall_42 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42: IPointer); - t_pcall_43 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43: IPointer); - t_pcall_44 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44: IPointer); - t_pcall_45 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45: IPointer); - t_pcall_46 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46: IPointer); - t_pcall_47 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47: IPointer); - t_pcall_48 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48: IPointer); - t_pcall_49 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49: IPointer); - t_pcall_50 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50: IPointer); - t_pcall_51 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51: IPointer); - t_pcall_52 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52: IPointer); - t_pcall_53 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53: IPointer); - t_pcall_54 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54: IPointer); - t_pcall_55 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55: IPointer); - t_pcall_56 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56: IPointer); - t_pcall_57 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57: IPointer); - t_pcall_58 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58: IPointer); - t_pcall_59 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59: IPointer); - t_pcall_60 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60: IPointer); - t_pcall_61 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61: IPointer); - t_pcall_62 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62: IPointer); - t_pcall_63 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63: IPointer); - t_pcall_64 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63,p64: IPointer); - t_pcall_65 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63,p64,p65: IPointer); - t_pcall_66 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, - p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, - p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63,p64,p65,p66: IPointer); -procedure x64call({RCX}Address: Pointer;out {RDX}_RAX: IPointer;var {R8}_XMM0: Double; var {R9}R: TRegisters); +{ implementation of x86 abi } +{$ifdef FPC} +{$define PS_ARRAY_ON_STACK} +{$endif} +function RealFloatCall_Register(p: Pointer; + _EAX, _EDX, _ECX: Cardinal; + StackData: Pointer; + StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes) + ): Extended; Stdcall; // make sure all things are on stack +var + E: Extended; begin - case R.Items of // stack items count - 00: t_pcall_04(Address)(R._RCX,R._RDX,R._R8,R._R9); - 01: t_pcall_05(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00]); - 02: t_pcall_06(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01]); - 03: t_pcall_07(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02]); - 04: t_pcall_08(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03]); - 05: t_pcall_09(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04]); - 06: t_pcall_10(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05]); - 07: t_pcall_11(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06]); - 08: t_pcall_12(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07]); - 09: t_pcall_13(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08]); - 10: t_pcall_14(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09]); - 11: t_pcall_15(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10]); - 12: t_pcall_16(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11]); - 13: t_pcall_17(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12]); - 14: t_pcall_18(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13]); - 15: t_pcall_19(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14]); - 16: t_pcall_20(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15]); - 17: t_pcall_21(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16]); - 18: t_pcall_22(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17]); - 19: t_pcall_23(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18]); - 20: t_pcall_24(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19]); - 21: t_pcall_25(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20]); - 22: t_pcall_26(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21]); - 23: t_pcall_27(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22]); - 24: t_pcall_28(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23]); - 25: t_pcall_29(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24]); - 26: t_pcall_30(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25]); - 27: t_pcall_31(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26]); - 28: t_pcall_32(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27]); - 29: t_pcall_33(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28]); - 30: t_pcall_34(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29]); - 31: t_pcall_35(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30]); - 32: t_pcall_36(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31]); - 33: t_pcall_37(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32]); - 34: t_pcall_38(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33]); - 35: t_pcall_39(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34]); - 36: t_pcall_40(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35]); - 37: t_pcall_41(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36]); - 38: t_pcall_42(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37]); - 39: t_pcall_43(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38]); - 40: t_pcall_44(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39]); - 41: t_pcall_45(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40]); - 42: t_pcall_46(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41]); - 43: t_pcall_47(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42]); - 44: t_pcall_48(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43]); - 45: t_pcall_49(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44]); - 46: t_pcall_50(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45]); - 47: t_pcall_51(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46]); - 48: t_pcall_52(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47]); - 49: t_pcall_53(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48]); - 50: t_pcall_54(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49]); - 51: t_pcall_55(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49],R.S[50]); - 52: t_pcall_56(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51]); - 53: t_pcall_57(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52]); - 54: t_pcall_58(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53]); - 55: t_pcall_59(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54]); - 56: t_pcall_60(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55]); - 57: t_pcall_61(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], - R.S[56]); - 58: t_pcall_62(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], - R.S[56],R.S[57]); - 59: t_pcall_63(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], - R.S[56],R.S[57],R.S[58]); - 60: t_pcall_64(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], - R.S[56],R.S[57],R.S[58],R.S[59]); - 61: t_pcall_65(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], - R.S[56],R.S[57],R.S[58],R.S[59],R.S[60]); - 62: t_pcall_66(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00],R.S[01],R.S[02],R.S[03],R.S[04],R.S[05], - R.S[06],R.S[07],R.S[08],R.S[09],R.S[10],R.S[11],R.S[12],R.S[13],R.S[14],R.S[15], - R.S[16],R.S[17],R.S[18],R.S[19],R.S[20],R.S[21],R.S[22],R.S[23],R.S[24],R.S[25], - R.S[26],R.S[27],R.S[28],R.S[29],R.S[30],R.S[31],R.S[32],R.S[33],R.S[34],R.S[35], - R.S[36],R.S[37],R.S[38],R.S[39],R.S[40],R.S[41],R.S[42],R.S[43],R.S[44],R.S[45], - R.S[46],R.S[47],R.S[48],R.S[49],R.S[50],R.S[51],R.S[52],R.S[53],R.S[54],R.S[55], - R.S[56],R.S[57],R.S[58],R.S[59],R.S[60],R.S[61]); - //} - else - raise EInvocationError.Create('Internal: Parameter count exceeded 64'); + asm + mov ecx, stackdatalen + jecxz @@2 + mov eax, stackdata + @@1: + mov edx, [eax] + push edx + sub eax, 4 + dec ecx + or ecx, ecx + jnz @@1 + @@2: + mov eax,_EAX + mov edx,_EDX + mov ecx,_ECX + call p + fstp tbyte ptr [e] end; + Result := E; end; -{$ENDIF} - -{$IFDEF X64CALL_ASM} -{$IFDEF WINDOWS} -type - //{$IFDEF UNICODE_OR_FPC}{$ALIGN 16}{$ENDIF} // For packed record mode - //{$ifdef FPC} - //{$PACKRECORDS 16} - //{$endif} - t_pstask = array[0..61] of IPointer; - p_pstask = ^t_pstask; - TRegisters = packed record - _RCX, // 0 - _RDX, // 8 - _R8, // 16 - _R9: IPointer; // 24 - _XMM1, // 32 - _XMM2, // 40 - _XMM3: Double; // 48 - case byte of - 0:( - Stack: Pointer; // 56 - Items: {$IFDEF FPC}PtrUInt{$ELSE}IntPtr{$ENDIF}; // 64 - SingleBits: Integer; // 72 - ); - 1:(S: p_pstask); +function RealFloatCall_Other(p: Pointer; + StackData: Pointer; + StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes) + ): Extended; Stdcall; // make sure all things are on stack +var + E: Extended; +begin + asm + mov ecx, stackdatalen + jecxz @@2 + mov eax, stackdata + @@1: + mov edx, [eax] + push edx + sub eax, 4 + dec ecx + or ecx, ecx + jnz @@1 + @@2: + call p + fstp tbyte ptr [e] end; - PRegisters=^TRegisters; - -{$IFDEF CPUX64} - - {$IFDEF DELPHI} - {$DEFINE REG_STACK_PTR_OFFSET0} { optional } // ! Successfully on exceptions ! - {$ENDIF} - - {$IFDEF FPC} - {$mode delphi} - {$ASMMODE INTEL} - {.$DEFINE REG_STACK_PTR_OFFSET0} { optional } // ! GPF on exceptions for both asm variants! - {$ENDIF} - -{$ENDIF CPUX64} - -{$IFDEF REG_STACK_PTR_OFFSET0} // ! NEW asm-win-x64 version for delphi and/or fpc ! + Result := E; +end; -procedure x64call({RCX}Address: Pointer;out {RDX}_RAX: IPointer;var {R8}_XMM0: Double; var {R9}RegInfo: TRegisters); -assembler; {$ifdef FPC}nostackframe;{$endif} - // - // !!! DELPHI: Successfully on exceptions ! - // !!! TODO: FPC: ! GPF on exception ! - // - procedure InvokeErrorParamCount; // The number of parameters exceeded 64 (c_par_max_count) - begin - raise EInvocationError.Create('Internal: Parameter count exceeded 64'); +function RealFloatCall_CDecl(p: Pointer; + StackData: Pointer; + StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes) + ): Extended; Stdcall; // make sure all things are on stack +var + E: Extended; +begin + asm + mov ecx, stackdatalen + jecxz @@2 + mov eax, stackdata + @@1: + mov edx, [eax] + push edx + sub eax, 4 + dec ecx + or ecx, ecx + jnz @@1 + @@2: + call p + fstp tbyte ptr [e] + @@5: + mov ecx, stackdatalen + jecxz @@2 + @@6: + pop edx + dec ecx + or ecx, ecx + jnz @@6 end; - // -const - c_par_max_count = 64; // == $40 - - c_sz_ptr = SizeOf(Pointer); // == 8 - c_arg_count = 4; // == 4 - c_arg_size = c_arg_count * c_sz_ptr; // == 32 - c_loc_count = c_par_max_count + 4; // == 68 - c_params = c_loc_count - c_arg_count + 1; // == 65 - - c_loc_offs_adress = c_loc_count * c_sz_ptr + c_arg_size; // == 576 - c_loc_offs__rax = c_loc_offs_adress + 1*c_sz_ptr; // == 584 - c_loc_offs__xmm0 = c_loc_offs_adress + 2*c_sz_ptr; // == 592 - c_loc_offs_reginfo = c_loc_offs_adress + 4*c_sz_ptr; // == 608 - - //c_reg_packed = ((SizeOf(TRegisters) mod c_sz_ptr) + c_sz_ptr - 1) div c_sz_ptr; // 1 - packed records; 0 - aligned -asm -{$ifdef DELPHI} - .params c_params // There's actually room for c_loc_count, assembler is saving locals for "Address,_RAX,_XMM0,RegInfo" -{$else} // TODO: FPC: GPF on exception - push rbp - sub rsp, $210 - mov rbp, rsp -{$endif} - - mov [rbp+c_loc_offs_adress], Address // save: rcx (@Address) - mov [rbp+c_loc_offs__rax], _RAX // save: rdx (@_RDX) - mov [rbp+c_loc_offs__xmm0], _XMM0 // save: r8 (@_XMM0) - mov [rbp+c_loc_offs_reginfo], RegInfo // save: r9 (@RegInfo) dbg: TRegisters(pointer(R9)^),r - - // - // check Registers.Items (param count limitation) - // - mov rcx, [RegInfo].TRegisters.Items - test rcx, rcx - jz @@skip_items - - cmp rcx, c_par_max_count-2 - jbe @@frame_is_try - - call InvokeErrorParamCount - -@@frame_is_try: - // - // copy registers: - // source : [RegInfo].TRegisters.Stack - // dest : [rbp + c_arg_count*c_sz_ptr] - // count : rcx - // note : All items on stack should be 16 byte aligned. Caller should have handled that, just copy data here. - // - mov r8, [RegInfo].TRegisters.Stack // source - lea rdx, [rbp + c_arg_count*c_sz_ptr] // dest -@copy_loop: - // copy pointer: - mov rax, [r8] - mov [rdx], rax - // next: - add r8, c_sz_ptr - add rdx, c_sz_ptr - dec rcx - or rcx, rcx - jnz @copy_loop - // next. - // - // copy registers. - -@@skip_items: - - // mov *, [r9].* ; [r9] == [RegInfo] - mov rcx, [RegInfo].TRegisters._RCX - mov rdx, [RegInfo].TRegisters._RDX - mov r8, [RegInfo].TRegisters._R8 - - movsd xmm0,[RegInfo].TRegisters._RCX - movsd xmm1,[RegInfo].TRegisters._RDX - movsd xmm2,[RegInfo].TRegisters._R8 - movsd xmm3,[RegInfo].TRegisters._R9 - - mov r9, [RegInfo].TRegisters._R9 // !!! Overwritten RegInfo (r9) - - call [rbp+c_loc_offs_adress] - - // make result - mov rdx, [rbp+c_loc_offs__rax] // restore: rdx (@_RDX) - mov [rdx], RAX // fill: _RAX - - //movsd [rdx+c_sz_ptr], XMM0 // fill: _XMM0 - mov rdx, [rbp+c_loc_offs__xmm0] // restore: r8 (@_RMM0) - mov [rdx], RAX // fill: _RAX - -{$ifdef DELPHI} -{$else} - lea rsp, [rbp+$210] - pop rbp - - ret -{$endif} + Result := E; end; -{$ELSE !IFDEF REG_STACK_PTR_OFFSET0} // ! asm-win-x64 version for delphi and/or fpc ! - - {$undef _demo_x64call_gpf_} - {.$IFDEF DEBUG} - {.$define _demo_x64call_gpf_} { optional } - {.$ENDIF} - -{$ifdef _demo_x64call_gpf_} -procedure demo_x64call_gpf(); +function RealCall_Register(p: Pointer; + _EAX, _EDX, _ECX: Cardinal; + StackData: Pointer; + StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes) + ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack +var + r: Longint; begin - raise Exception.Create('Demo x64 GPF!'); + asm + mov ecx, stackdatalen + jecxz @@2 + mov eax, stackdata + @@1: + mov edx, [eax] + push edx + sub eax, 4 + dec ecx + or ecx, ecx + jnz @@1 + @@2: + mov eax,_EAX + mov edx,_EDX + mov ecx,_ECX + call p + mov ecx, resultlength + cmp ecx, 0 + je @@5 + cmp ecx, 1 + je @@3 + cmp ecx, 2 + je @@4 + mov r, eax + jmp @@5 + @@3: + xor ecx, ecx + mov cl, al + mov r, ecx + jmp @@5 + @@4: + xor ecx, ecx + mov cx, ax + mov r, ecx + @@5: + mov ecx, resedx + jecxz @@6 + mov [ecx], edx + @@6: + end; + Result := r; end; -{$endif} - -procedure x64call( // TODO: ! GPF on exception ! - Address: Pointer; - out _RAX: IPointer; - var _XMM0: Double; - var Registers: TRegisters); assembler; {$IFDEF FPC}nostackframe;{$ENDIF} -asm -(* Registers: - RCX: Address - RDX: *_RAX - R8: * _XMM0 - R9: _REGISTERS - fpc inserts an 20h empty space -*) -//{$IFDEF FPC} - push rbp - mov rbp,rsp -//{$ENDIF} - push rcx // address ;rbp -8 - push rdx // @_rax ;rbp -16 - push r8 // @_xmm0 ;rbp -24 - push r9 // _registers ;rbp -32 - - mov rax, [rbp-32] //registers - - mov rcx, [rax+64] // items/count - mov rdx, [rax+56] // stack - jmp @compareitems -@work: -{$IFDEF FPC} - push qword ptr [rdx] -{$ELSE} - push [rdx] -{$ENDIF} - dec rcx - sub rdx,8 -@compareitems: - or rcx, rcx - jnz @work - // copy registers - mov rcx, [rax+72] // single bits - - bt rcx, 1 - jnc @g1 - cvtsd2ss xmm1, [rax+32] - jmp @g1e - @g1: - movsd xmm1, [rax+32] - @g1e: - - bt rcx, 2 - jnc @g2 - cvtsd2ss xmm2, [rax+40] - jmp @g2e - @g2: - movsd xmm2, [rax+40] - @g2e: - - bt rcx, 3 - jnc @g3 - cvtsd2ss xmm3, [rax+48] - jmp @g3e - @g3: - movsd xmm3, [rax+48] - @g3e: - - // rbp-16: address of xmm0 - - bt rcx, 0 - jnc @g0 - mov rdx, [rbp -24] - cvtsd2ss xmm0, [rdx] - jmp @g0e - @g0: - mov rdx, [rbp -24] - movsd xmm0, [rdx] - @g0e: - - // other registers - mov rcx, [rax] - mov rdx, [rax+8] - mov r8, [rax+16] - mov r9, [rax+24] - - mov RAX, [rbp-8] - - // weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in - sub RSP, 32 - -{$ifdef _demo_x64call_gpf_} - // Demonstration GPF: - call demo_x64call_gpf -{$endif} - - call RAX - - add RSP, 32 // undo the damage done earlier - - // copy result back - mov RDX, [rbp-16] - mov [RDX], RAX - - mov rax, [rbp-32] //registers - - bt [rax+72], 8 // if atype.basetype <> btSingle - jnc @g5 // - cvtss2sd xmm1,xmm0 // convert single to double into xmm1 - mov rdx,[rbp-24] // @_xmm0 ;rbp -24 - movsd qword ptr [rdx], xmm1 // save xmm1 to param _xmm0 - jmp @g5e // exit if atype.basetype = btSingle - - @g5: //else "if atype.basetype = btSingle" - mov rdx,[rbp-24] // @_xmm0 ;rbp -24 - movsd qword ptr [rdx], xmm0 // save xmm1 to param _xmm0 - - @g5e: - - leave - ret +function RealCall_Other(p: Pointer; + StackData: Pointer; + StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes) + ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack +var + r: Longint; +begin + asm + mov ecx, stackdatalen + jecxz @@2 + mov eax, stackdata + @@1: + mov edx, [eax] + push edx + sub eax, 4 + dec ecx + or ecx, ecx + jnz @@1 + @@2: + call p + mov ecx, resultlength + cmp ecx, 0 + je @@5 + cmp ecx, 1 + je @@3 + cmp ecx, 2 + je @@4 + mov r, eax + jmp @@5 + @@3: + xor ecx, ecx + mov cl, al + mov r, ecx + jmp @@5 + @@4: + xor ecx, ecx + mov cx, ax + mov r, ecx + @@5: + mov ecx, resedx + jecxz @@6 + mov [ecx], edx + @@6: + end; + Result := r; end; -{$ENDIF !IFDEF REG_STACK_PTR_OFFSET0} -{$ELSE !WINDOWS} // ! Not windows version ! -type - //{$IFDEF UNICODE_OR_FPC}{$ALIGN 16}{$ENDIF} // For packed record mode - //{$ifdef FPC} - //{$PACKRECORDS 16} - //{$endif} - TRegisters = packed record - _RDI, // 0 - _RSI, // 8 - _RDX, // 16 - _RCX, // 24 - _R8, // 32 - _R9: IPointer; // 40 - _XMM1, // 48 - _XMM2, // 56 - _XMM3, // 64 - _XMM4, // 72 - _XMM5, // 80 - _XMM6, // 88 - _XMM7: Double; // 96 - SingleBits: Integer; //104 +function RealCall_CDecl(p: Pointer; + StackData: Pointer; + StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes) + ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack +var + r: Longint; +begin + asm + mov ecx, stackdatalen + jecxz @@2 + mov eax, stackdata + @@1: + mov edx, [eax] + push edx + sub eax, 4 + dec ecx + or ecx, ecx + jnz @@1 + @@2: + call p + mov ecx, resultlength + cmp ecx, 0 + je @@5 + cmp ecx, 1 + je @@3 + cmp ecx, 2 + je @@4 + mov r, eax + jmp @@5 + @@3: + xor ecx, ecx + mov cl, al + mov r, ecx + jmp @@5 + @@4: + xor ecx, ecx + mov cx, ax + mov r, ecx + @@5: + mov ecx, stackdatalen + jecxz @@7 + @@6: + pop eax + dec ecx + or ecx, ecx + jnz @@6 + mov ecx, resedx + jecxz @@7 + mov [ecx], edx + @@7: end; - -procedure x64call( // TODO: Need check GPF on exception ! - Address: Pointer; - out _RAX: IPointer; - var Registers: TRegisters; - aStack: Pointer; aItems: Integer; var _XMM0: Double); assembler; nostackframe; -asm -(* Registers: - RDI: Address - RSI: _RAX - RDX: Registers - RCX: aStack - R8: aItems - R9: XMM0 - - rbp-8 addr - rbp-16 _rax - rbp-24 _xmm0 - rbp-32 regs -*) - push rbp - mov rbp,rsp - push rdi // address - push rsi // _rax - push r9 // xmm0 - push rdx -{$IFDEF PS_STACKALIGN} - bt r8, 0 - jnc @skipjump - sub rsp, 8 -@skipjump: -{$ENDIF} - mov rax, rdx - jmp @compareitems -@work: -{$IFDEF FPC} - push qword ptr [rcx] -{$ELSE} - push [rcx] -{$ENDIF} - dec r8 - sub rcx,8 -@compareitems: - or r8, r8 - jnz @work - - // copy registers - // xmm0 - mov rdx,[rbp-24] - bt [rax+104], 0 - jnc @skipxmm0 - cvtsd2ss xmm0,[rdx] - jmp @skipxmm0re - @skipxmm0: - movq xmm0,[rdx] // move quadword to xmm0 from _XMM0 - @skipxmm0re: - - // xmm1 - bt [rax+104], 1 - jnc @skipxmm1 - cvtsd2ss xmm1,[rax+48] - jmp @skipxmm1re - @skipxmm1: - movq xmm1,[rax+48] // move quadword to xmm1 from Registers._XMM1 - @skipxmm1re: - - // xmm2 - bt [rax+104], 2 - jnc @skipxmm2 - cvtsd2ss xmm2,[rax+56] - jmp @skipxmm2re - @skipxmm2: - movq xmm2,[rax+56] // move quadword to xmm2 from Registers._XMM2 - @skipxmm2re: - - // xmm3 - bt [rax+104], 3 - jnc @skipxmm3 - cvtsd2ss xmm3,[rax+64] - jmp @skipxmm3re - @skipxmm3: - movq xmm3,[rax+64] // move quadword to xmm3 from Registers._XMM3 - @skipxmm3re: - - // xmm4 - bt [rax+104], 4 - jnc @skipxmm4 - cvtsd2ss xmm4,[rax+72] - jmp @skipxmm4re - @skipxmm4: - movq xmm4,[rax+72] // move quadword to xmm4 from Registers._XMM4 - @skipxmm4re: - - // xmm5 - bt [rax+104], 5 - jnc @skipxmm5 - cvtsd2ss xmm5,[rax+80] - jmp @skipxmm5re - @skipxmm5: - movq xmm5,[rax+80] // move quadword to xmm5 from Registers._XMM5 - @skipxmm5re: - - // xmm6 - bt [rax+104], 6 - jnc @skipxmm6 - cvtsd2ss xmm6,[rax+88] - jmp @skipxmm6re - @skipxmm6: - movq xmm6,[rax+88] // move quadword to xmm6 from Registers._XMM6 - @skipxmm6re: - - // xmm7 - bt [rax+104], 7 - jnc @skipxmm7 - cvtsd2ss xmm7,[rax+96] - jmp @skipxmm7re - @skipxmm7: - movq xmm7,[rax+96] // move quadword to xmm7 from Registers._XMM7 - @skipxmm7re: - - mov RDI, [rax] - mov RSI, [rax+ 8] - mov RDX, [rax+16] - mov RCX, [rax+24] - mov R8, [rax+32] - mov R9, [rax+40] - - // weird thing on windows, it needs 32 bytes in the CALLEE side to do whatever in; not sure about linux - //sub RSP, 32 - - mov rax, [rbp-8] - call RAX - - // add rsp, 8 - - // add rsp, 32 // undo the damage done earlier - - // copy result back - mov rsi, [rbp-16] // _RAX parameter - mov [rsi], RAX - mov rsi, [rbp-24] // _XMM0 parameter - - // xmm0 res - mov rax, [rbp-32] // Registers parameter - bt [rax+104], 8 // if atype.basetype <> btSingle - jnc @skipres // then goto skipres else begin - cvtss2sd xmm1,xmm0 // convert single to double into xmm1 - movq [rsi],xmm1 // move quadword to _XMM0 - jmp @skipresre // end - @skipres: - movq [rsi],xmm0 // move quadword to _XMM0 - @skipresre: - - pop rdx - pop r9 // xmm0 - pop rsi // _rax - pop rdi // address - leave - ret + Result := r; end; -{$ENDIF !WINDOWS} -{$ENDIF X64CALL_ASM} +const + EmptyPchar: array[0..0] of char = #0; function TPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TPSCallingConvention; Params: TPSList; res: PPSVariantIFC): Boolean; var - Stack: array of Byte; - _RAX: IPointer; - _XMM0: Double; - Registers: TRegisters; - {$IFNDEF WINDOWS} - RegUsageFloat: Byte; - {$ENDIF} -{$IFDEF FPC} - IsConstructor,IsVirtualCons: Boolean; -{$ENDIF} + Stack: ansistring; + I: Longint; RegUsage: Byte; CallData: TPSList; - I: Integer; pp: ^Byte; +{$IFDEF FPC} + IsConstructor,IsVirtualCons: Boolean; + MethodData: TMethod; +{$ENDIF} + + EAX, EDX, ECX: Longint; function rp(p: PPSVariantIFC): PPSVariantIFC; begin - if (p = nil) or (p.aType = nil) then begin + if p = nil then + begin result := nil; exit; end; - if p.aType.BaseType = btPointer then begin - p^.aType := Pointer(Pointer(IPointer(p^.dta) + PointerSize)^); + if p.aType.BaseType = btPointer then + begin + p^.aType := Pointer(Pointer(IPointer(p^.dta) + 4)^); p^.Dta := Pointer(p^.dta^); end; Result := p; end; - {$IFDEF WINDOWS} - procedure StoreReg(data: IPointer); overload; - var p: Pointer; - begin - case RegUsage of - 0: begin inc(RegUsage); Registers._RCX:=Data; end; - 1: begin inc(RegUsage); Registers._RDX:=Data; end; - 2: begin inc(RegUsage); Registers._R8:=Data; end; - 3: begin inc(RegUsage); Registers._R9:=Data; end; - else begin - SetLength(Stack, Length(Stack)+8); - p := @Stack[Length(Stack)-8]; - IPointer(p^) := data; - end; - end; - end; - {$ELSE !WINDOWS} - procedure StoreReg(data: IPointer); overload; - var p: Pointer; - begin - case RegUsage of - 0: begin inc(RegUsage); Registers._RDI:=Data; end; - 1: begin inc(RegUsage); Registers._RSI:=Data; end; - 2: begin inc(RegUsage); Registers._RDX:=Data; end; - 3: begin inc(RegUsage); Registers._RCX:=Data; end; - 4: begin inc(RegUsage); Registers._R8:=Data; end; - 5: begin inc(RegUsage); Registers._R9:=Data; end; - else begin - SetLength(Stack, Length(Stack)+8); - p := @Stack[Length(Stack)-8]; - IPointer(p^) := data; - end; - end; - end; - {$ENDIF !WINDOWS} - - procedure StoreStack(const aData; Len: Integer); - var - p: Pointer; - begin - if Len > 8 then - if Length(Stack) mod 16 <> 0 then begin - SetLength(Stack, Length(Stack)+ (16-(Length(Stack) mod 16))); - end; - SetLength(Stack, Length(Stack)+Len); - p := @Stack[Length(Stack)-Len]; - Move(aData, p^, Len); - end; - - {$IFDEF WINDOWS} - procedure StoreReg(data: Double); overload; - var p: Pointer; - begin - case RegUsage of - 0: begin inc(RegUsage); _XMM0:=Data; end; - 1: begin inc(RegUsage); Registers._XMM1:=Data; end; - 2: begin inc(RegUsage); Registers._XMM2:=Data; end; - 3: begin inc(RegUsage); Registers._XMM3:=Data; end; - else begin - SetLength(Stack, Length(Stack)+8); - p := @Stack[Length(Stack)-8]; - Double(p^) := data; - end; - end; - end; - procedure StoreReg(data: Single); overload; - var p: Pointer; - begin - case RegUsage of - 0: begin inc(RegUsage); Registers.SingleBits := Registers.SingleBits or 1;_XMM0:=Data; end; - 1: begin inc(RegUsage); Registers.SingleBits := Registers.SingleBits or 2; Registers._XMM1:=Data; end; - 2: begin inc(RegUsage); Registers.SingleBits := Registers.SingleBits or 4;Registers._XMM2:=Data; end; - 3: begin inc(RegUsage); Registers.SingleBits := Registers.SingleBits or 8; Registers._XMM3:=Data; end; - else begin - SetLength(Stack, Length(Stack)+8); - p := @Stack[Length(Stack)-8]; - Double(p^) := data; - end; - end; - end; - {$ELSE !WINDOWS} - procedure StoreReg(data: Double); overload; - var p: Pointer; - begin - case RegUsageFloat of - 0: begin inc(RegUsageFloat); _XMM0:=Data; end; - 1: begin inc(RegUsageFloat); Registers._XMM1:=Data; end; - 2: begin inc(RegUsageFloat); Registers._XMM2:=Data; end; - 3: begin inc(RegUsageFloat); Registers._XMM3:=Data; end; - 4: begin inc(RegUsageFloat); Registers._XMM4:=Data; end; - 5: begin inc(RegUsageFloat); Registers._XMM5:=Data; end; - 6: begin inc(RegUsageFloat); Registers._XMM6:=Data; end; - 7: begin inc(RegUsageFloat); Registers._XMM7:=Data; end; - else begin - SetLength(Stack, Length(Stack)+8); - p := @Stack[Length(Stack)-8]; - Double(p^) := data; - end; - end; - end; - procedure StoreReg(data: Single); overload; - var p: Pointer; - begin - case RegUsageFloat of - 0: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 1; _XMM0:=Data; end; - 1: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 2; Registers._XMM1:=Data; end; - 2: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 4; Registers._XMM2:=Data; end; - 3: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 8; Registers._XMM3:=Data; end; - 4: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 16; Registers._XMM4:=Data; end; - 5: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 32; Registers._XMM5:=Data; end; - 6: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 64; Registers._XMM6:=Data; end; - 7: begin inc(RegUsageFloat); Registers.SingleBits := Registers.SingleBits or 128; Registers._XMM7:=Data; end; - else begin - SetLength(Stack, Length(Stack)+8); - p := @Stack[Length(Stack)-8]; - Double(p^) := data; - end; - end; - end; - {$ENDIF !WINDOWS} - - type - TMethodCallData = record - AType: Byte; - Data: TMethod; - end; - PMethodCallData=^TMethodCallData; function GetPtr(fVar: PPSVariantIFC): Boolean; var varPtr: Pointer; + UseReg: Boolean; + tempstr: tbtstring; p: Pointer; begin Result := False; - if fVar = nil then exit; + if FVar = nil then exit; if fVar.VarParam then begin - case fVar.aType.BaseType of - btArray: begin - if Copy(fVar.aType.ExportName, 1, 10) = '!OPENARRAY' then begin - p := CreateOpenArray(True, Self, fVar); + case fvar.aType.BaseType of + btArray: + begin + if Copy(fvar.aType.ExportName, 1, 10) = '!OPENARRAY' then + begin + p := CreateOpenArray(True, Self, FVar); if p = nil then exit; - if CallData = nil then - CallData := TPSList.Create; CallData.Add(p); - StoreReg(IPointer(POpenArray(p)^.Data)); - StoreReg(IPointer(POpenArray(p)^.ItemCount -1)); + case RegUsage of + 0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; + 1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; + 2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; + else begin + Stack := StringOfChar(AnsiChar(#0),4) + Stack; + Pointer((@Stack[1])^) := POpenArray(p)^.Data; + end; + end; + case RegUsage of + 0: begin EAX := Longint(POpenArray(p)^.ItemCount - 1); Inc(RegUsage); end; + 1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; + 2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; + else begin + Stack := StringOfChar(AnsiChar(#0),4) + Stack; + Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1; + end; + end; Result := True; Exit; end else begin - varptr := fVar.Dta; - //Exit; + {$IFDEF PS_DYNARRAY} + varptr := fvar.Dta; + {$ELSE} + Exit; + {$ENDIF} end; end; btVariant, @@ -1124,105 +326,190 @@ var btRecord, btInterface, btClass, - {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar,{$ENDIF} btU8, btS8, btU16, + {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency - {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: begin - Varptr := fVar.Dta; + {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: + begin + Varptr := fvar.Dta; end; - else begin - Exit; // invalid type + else begin + exit; //invalid type end; end; {case} - StoreReg(IPointer(VarPtr)); - end else begin { #else : (not fVar.VarParam) } - case fVar.aType.BaseType of - btSet: begin - case TPSTypeRec_Set(fVar.aType).aByteSize of - 1: StoreReg(IPointer(byte(fVar.dta^))); - 2: StoreReg(IPointer(word(fVar.dta^))); - 3, 4: StoreReg(IPointer(cardinal(fVar.dta^))); - 5,6,7,8: StoreReg(IPointer(fVar.Dta^)); + case RegUsage of + 0: begin EAX := Longint(VarPtr); Inc(RegUsage); end; + 1: begin EDX := Longint(VarPtr); Inc(RegUsage); end; + 2: begin ECX := Longint(VarPtr); Inc(RegUsage); end; + else begin + Stack := StringOfChar(AnsiChar(#0),4) + Stack; + Pointer((@Stack[1])^) := VarPtr; + end; + end; + end else begin + UseReg := True; + case fVar^.aType.BaseType of + btSet: + begin + tempstr := StringOfChar(AnsiChar(#0),4); + case TPSTypeRec_Set(fvar.aType).aByteSize of + 1: Byte((@tempstr[1])^) := byte(fvar.dta^); + 2: word((@tempstr[1])^) := word(fvar.dta^); + 3, 4: cardinal((@tempstr[1])^) := cardinal(fvar.dta^); else - StoreReg(IPointer(fVar.Dta)); + pointer((@tempstr[1])^) := fvar.dta; end; end; - btArray: begin - if Copy(fVar.aType.ExportName, 1, 10) = '!OPENARRAY' then begin - p := CreateOpenArray(False, Self, fVar); + btArray: + begin + if Copy(fvar^.aType.ExportName, 1, 10) = '!OPENARRAY' then + begin + p := CreateOpenArray(False, SElf, FVar); if p =nil then exit; - if CallData = nil then - CallData := TPSList.Create; CallData.Add(p); - StoreReg(IPointer(POpenArray(p)^.Data)); - StoreReg(IPointer(POpenArray(p)^.ItemCount -1)); + case RegUsage of + 0: begin EAX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; + 1: begin EDX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; + 2: begin ECX := Longint(POpenArray(p)^.Data); Inc(RegUsage); end; + else begin + Stack := StringOfChar(AnsiChar(#0),4) + Stack; + Pointer((@Stack[1])^) := POpenArray(p)^.Data; + end; + end; + case RegUsage of + 0: begin EAX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; + 1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; + 2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end; + else begin + Stack := StringOfChar(AnsiChar(#0),4) + Stack; + Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1; + end; + end; Result := True; exit; end else begin - StoreReg(IPointer(fVar.Dta{$IFNDEF FPC}^{$ENDIF})); + {$IFDEF PS_DYNARRAY} + TempStr := StringOfChar(AnsiChar(#0),4); + Pointer((@TempStr[1])^) := Pointer(fvar.Dta^); + {$IFDEF PS_ARRAY_ON_STACK} + UseReg := false; + {$ENDIF} + {$ELSE} + Exit; + {$ENDIF} end; end; - btRecord: begin - if fVar.aType.RealSize <= sizeof(IPointer) then - StoreReg(IPointer(fVar.dta^)) - else - StoreReg(IPointer(fVar.Dta)); - end; - btVariant, btStaticArray: begin - StoreReg(IPointer(fVar.Dta)); + btVariant + , btStaticArray, btRecord: + begin + TempStr := StringOfChar(AnsiChar(#0),4); + Pointer((@TempStr[1])^) := Pointer(fvar.Dta); end; - btExtended, btDouble: {8 bytes} begin - StoreReg(double(fVar.dta^)); + btDouble: {8 bytes} begin + TempStr := StringOfChar(AnsiChar(#0),8); + UseReg := False; + double((@TempStr[1])^) := double(fvar.dta^); end; btCurrency: {8 bytes} begin - StoreReg(IPointer(fVar.dta^)); + TempStr := StringOfChar(AnsiChar(#0),8); + UseReg := False; + currency((@TempStr[1])^) := currency(fvar.dta^); end; btSingle: {4 bytes} begin - StoreReg(single(fVar.dta^)); + TempStr := StringOfChar(AnsiChar(#0),4);; + UseReg := False; + Single((@TempStr[1])^) := single(fvar.dta^); end; - btChar, btU8, btS8: begin - StoreReg(IPointer(byte(fVar.dta^))); + btExtended: {10 bytes} begin + UseReg := False; + TempStr:= StringOfChar(AnsiChar(#0),12); + Extended((@TempStr[1])^) := extended(fvar.dta^); + end; + btChar, + btU8, + btS8: begin + TempStr := tbtchar(fVar^.dta^) + tbtstring(StringOfChar(AnsiChar(#0),3)); end; - btWideChar, - btU16, btS16: begin - StoreReg(IPointer(word(fVar.dta^))); + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF} + btu16, btS16: begin + TempStr := StringOfChar(AnsiChar(#0),4); + Word((@TempStr[1])^) := word(fVar^.dta^); end; - btU32, btS32: begin - StoreReg(IPointer(cardinal(fVar.dta^))); + btu32, bts32: begin + TempStr := StringOfChar(AnsiChar(#0),4); + Longint((@TempStr[1])^) := Longint(fVar^.dta^); end; - btPChar: begin - if Pointer(fVar.dta^) = nil then - StoreReg(IPointer(@EmptyPChar)) + btPchar: + begin + TempStr := StringOfChar(AnsiChar(#0),4); + if pointer(fvar^.dta^) = nil then + Pointer((@TempStr[1])^) := @EmptyPchar else - StoreReg(IPointer(fVar.dta^)); + Pointer((@TempStr[1])^) := pointer(fvar^.dta^); end; - btClass, btInterface, btString: begin - StoreReg(IPointer(fVar.dta^)); + btclass, btinterface, btString: + begin + TempStr := StringOfChar(AnsiChar(#0),4); + Pointer((@TempStr[1])^) := pointer(fvar^.dta^); end; + {$IFNDEF PS_NOWIDESTRING} btWideString: begin - StoreReg(IPointer(fVar.dta^)); + TempStr := StringOfChar(AnsiChar(#0),4); + Pointer((@TempStr[1])^) := pointer(fvar^.dta^); end; btUnicodeString: begin - StoreReg(IPointer(fVar.dta^)); + TempStr := StringOfChar(AnsiChar(#0),4); + Pointer((@TempStr[1])^) := pointer(fvar^.dta^); end; - btProcPtr: begin - p := New(PMethodCallData); - TMethodCallData(p^).AType:=255; - if CallData = nil then - CallData := TPSList.Create; - CallData.Add(p); - TMethodCallData(p^).Data := MKMethod(Self, Longint(fVar.Dta^)); // It requires the implementation of "Handled" - StoreReg(IPointer(@TMethodCallData(p^).Data)); - end; - btS64: begin - StoreReg(IPointer(int64(fVar.dta^))); + {$ENDIF} + + btProcPtr: + begin +{$IFDEF FPC} + MethodData := MKMethod(Self, Longint(FVar.Dta^)); + TempStr := StringOfChar(AnsiChar(#0),4); + Pointer((@TempStr[1])^) := @MethodData; +{$ELSE} + TempStr := StringOfChar(AnsiChar(#0),8); + TMethod((@TempStr[1])^) := MKMethod(Self, Longint(FVar.Dta^)); + UseReg := false; +{$ENDIF} end; + + {$IFNDEF PS_NOINT64}bts64: + begin + TempStr:= StringOfChar(AnsiChar(#0),8); + Int64((@TempStr[1])^) := int64(fvar^.dta^); + UseReg := False; + end;{$ENDIF} end; {case} - end; { #if else : (not fVar.VarParam) } + if UseReg then + begin + case RegUsage of + 0: begin EAX := Longint((@Tempstr[1])^); Inc(RegUsage); end; + 1: begin EDX := Longint((@Tempstr[1])^); Inc(RegUsage); end; + 2: begin ECX := Longint((@Tempstr[1])^); Inc(RegUsage); end; + else begin + {$IFDEF FPC_OLD_FIX} + if CallingConv = cdRegister then + Stack := Stack + TempStr + else + {$ENDIF} + Stack := TempStr + Stack; + end; + end; + end else begin + {$IFDEF FPC_OLD_FIX} + if CallingConv = cdRegister then + Stack := Stack + TempStr + else + {$ENDIF} + Stack := TempStr + Stack; + end; + end; Result := True; - end; // function GetPtr - -begin // function TPSExec.InnerfuseCall + end; +begin {$IFDEF FPC} if (Integer(CallingConv) and 128) <> 0 then begin IsVirtualCons := true; @@ -1238,183 +525,259 @@ begin // function TPSExec.InnerfuseCall InnerfuseCall := False; if Address = nil then exit; // need address - SetLength(Stack, 0); - CallData := nil; + Stack := ''; + CallData := TPSList.Create; res := rp(res); if res <> nil then res.VarParam := true; try -{$IFNDEF WINDOWS} - (*_RSI := 0; - _RDI := 0; - _XMM4 := 0; - _XMM5 := 0; - _XMM6 := 0; - _XMM7 := 0;*) - RegUsageFloat := 0; + case CallingConv of + cdRegister: begin + EAX := 0; + EDX := 0; + ECX := 0; + RegUsage := 0; + +{$IFDEF FPC} // FIX FOR FPC constructor calls + if IsConstructor then begin + if not GetPtr(rp(Params[0])) then exit; // this goes first + RegUsage := 2; + EDX := Longint(_Self); + DisposePPSVariantIFC(Params[0]); + Params.Delete(0); + end else {$ENDIF} - _XMM0 := 0; - FillChar(Registers, Sizeof(Registers), 0); - _RAX := 0; - RegUsage := 0; - {$warnings off} - {$IF DEFINED (fpc) and (fpc_version >= 3)} // FIX FOR FPC constructor calls - {$warnings on} - if IsConstructor then begin - if not GetPtr(rp(Params[0])) then exit; // this goes first - DisposePPSVariantIFC(Params[0]); - Params.Delete(0); - end; - {$ENDIF} - if assigned(_Self) then begin - StoreReg(IPointer(_Self)); - end; - if assigned(res) and (res^.atype.basetype = btSingle) then begin - Registers.Singlebits := Registers.Singlebits or 256; - end; - {$IFDEF PS_RESBEFOREPARAMETERS} - if assigned(res) then begin - case res^.aType.BaseType of - {$IFDEF x64_string_result_as_varparameter} - {$IFNDEF PS_NOWIDESTRING} - btWideString, btUnicodeString, - {$ENDIF} - {.$IFNDEF PS_FPCSTRINGWORKAROUND} - btString, - {.$ENDIF} - {$ENDIF x64_string_result_as_varparameter} - btInterface, btArray, btVariant, btStaticArray: - GetPtr(res); - btRecord, - btSet: - begin - if res.aType.RealSize > PointerSize then - GetPtr(res); + if assigned(_Self) then begin + RegUsage := 1; + EAX := Longint(_Self); end; - end; - end; - {$ENDIF PS_RESBEFOREPARAMETERS} - for I := 0 to Params.Count - 1 do begin - if not GetPtr(rp(Params[I])) then - Exit; - end; - if assigned(res) then begin - {$IFNDEF PS_RESBEFOREPARAMETERS} - case res^.aType.BaseType of - {$IFDEF x64_string_result_as_varparameter} - btstring, btWideString, btUnicodeString, - {$ENDIF} - btInterface, btArray, btVariant, btStaticArray: - GetPtr(res); - btRecord, - btSet: - begin - if res.aType.RealSize > PointerSize then - GetPtr(res); - end; - end; - {$ENDIF !PS_RESBEFOREPARAMETERS} - {$IFDEF WINDOWS} - if (length(Stack) mod 16) <> 0 then begin - SetLength(Stack, Length(Stack)+16 - (Length(Stack) mod 16)); - end; - {$ENDIF} - if Stack = nil - then pp := nil - else pp := @Stack[{$IFDEF REG_STACK_PTR_OFFSET0}0{$ELSE}Length(Stack)-8{$ENDIF}]; - - {$IFDEF WINDOWS} - Registers.Stack := pp; - Registers.Items := Length(Stack) div 8; - x64call(Address, _RAX, _XMM0, Registers); - {$ELSE} - x64call(Address, _RAX, Registers, pp, Length(Stack) div 8, _XMM0); - {$ENDIF !WINDOWS} - case res^.aType.BaseType of - btRecord, btSet: + for I := 0 to Params.Count - 1 do begin - case res.aType.RealSize of - 1: byte(res.Dta^) := _RAX; - 2: word(res.Dta^) := _RAX; - 3, - 4: Longint(res.Dta^) := _RAX; - 5,6,7,8: IPointer(res.dta^) := _RAX; - end; + if not GetPtr(rp(Params[I])) then Exit; end; - btSingle: - tbtsingle(res.Dta^) := _XMM0; - btDouble: - tbtdouble(res.Dta^) := _XMM0; - btExtended: - tbtextended(res.Dta^) := _XMM0; - btChar, btU8, btS8: - tbtu8(res.dta^) := _RAX; - - {$IFNDEF PS_NOWIDESTRING} - btWideChar, - {$ENDIF} - btu16, bts16: tbtu16(res.dta^) := _RAX; - - btClass : - IPointer(res.dta^) := _RAX; - btu32, bts32: - tbtu32(res.dta^) := _RAX; - btPChar: - pansichar(res.dta^) := Pansichar(_RAX); - bts64: - tbts64(res.dta^) := Int64(_RAX); - btCurrency: - tbtCurrency(res.Dta^) := Int64(_RAX); - - btInterface, - btVariant, - {$IFDEF x64_string_result_as_varparameter} - btWidestring, btUnicodestring, btString, - {$ENDIF} - btStaticArray, btArray:; - {$IFNDEF x64_string_result_as_varparameter} - btUnicodeString, btWideString, btstring: - Int64(res.dta^) := _RAX; - {$ENDIF} - else - exit; - end; // case - end else begin // when res==nil - {$IFDEF WINDOWS} - if (length(Stack) mod 16) <> 0 then begin - SetLength(Stack, Length(Stack)+16 - (Length(Stack) mod 16)); + if assigned(res) then begin + case res^.aType.BaseType of + {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF} + btInterface, {$IFNDEF FPC} btArray, {$ENDIF}btrecord, {$IFNDEF PS_FPCSTRINGWORKAROUND}btstring, {$ENDIF}btVariant, btStaticArray: GetPtr(res); + btSet: + begin + if TPSTypeRec_Set(res.aType).aByteSize >4 then GetPtr(res); + end; + end; + {$IFDEF DARWIN} + if (length(Stack) mod 16) <> 0 then begin + Stack := Stack + StringOfChar(ansichar(#32), 16 - (Length(Stack) mod 16)) ; + end; + {$ENDIF} + case res^.aType.BaseType of + btSet: + begin + case TPSTypeRec_Set(res.aType).aByteSize of + 1: byte(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + 2: word(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); + 3, + 4: Longint(res.Dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + else RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil) + end; + end; + btSingle: tbtsingle(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4); + btDouble: tbtdouble(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4); + btExtended: tbtextended(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4); + btchar,btU8, btS8: tbtu8(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); + btClass : + begin + {$IF DEFINED (fpc) and (fpc_version < 3)} + if IsConstructor or IsVirtualCons then + tbtu32(res.dta^) := RealCall_Register(Address, EDX, EAX, ECX, + @Stack[Length(Stack) - 3], Length(Stack) div 4, 4, nil) + else + {$IFEND} + tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, + @Stack[Length(Stack) - 3], Length(Stack) div 4, 4, nil); + end; + + btu32,bts32{$IFDEF FPC},btArray{$ENDIF}: tbtu32(res.dta^) := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + btPChar: pansichar(res.dta^) := Pansichar(RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + {$IFNDEF PS_NOINT64}bts64: + begin + EAX := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); + tbts64(res.dta^) := Int64(Cardinal(EDX)) shl 32 or Cardinal(EAX); + end; + {$ENDIF} + btCurrency: tbtCurrency(res.Dta^) := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4) / 10000; + btInterface, + btVariant, + {$IFNDEF PS_NOWIDESTRING}btWidestring,btUnicodestring, {$ENDIF} + btStaticArray, {$IFNDEF FPC} btArray,{$ENDIF} btrecord{$IFNDEF PS_FPCSTRINGWORKAROUND}, btstring {$ENDIF}: RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + {$IFDEF PS_FPCSTRINGWORKAROUND} + btstring: begin + eax := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + Longint(res.dta^) := eax; + end; + {$ENDIF} + else + exit; + end; + end else begin + {$IFDEF DARWIN} + if (length(Stack) mod 16) <> 0 then begin + Stack := Stack + StringOfChar(ansichar(#32), 16 - (Length(Stack) mod 16)) ; + end; + {$ENDIF} + RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end; - {$ENDIF} - if Stack = nil - then pp := nil - else pp := @Stack[{$IFDEF REG_STACK_PTR_OFFSET0}0{$ELSE}Length(Stack)-8{$ENDIF}]; + Result := True; + end; + cdPascal: begin + RegUsage := 3; + for I := 0 to Params.Count - 1 do begin + if not GetPtr(Params[i]) then Exit; + end; + if assigned(res) then begin + case res^.aType.BaseType of + {$IFNDEF PS_NOWIDESTRING}btWideString, btUnicodeString, {$ENDIF}btInterface, btArray, btrecord, btstring, btVariant: GetPtr(res); + end; + end; + if assigned(_Self) then begin + Stack := StringOfChar(AnsiChar(#0),4) +Stack; + Pointer((@Stack[1])^) := _Self; + end; + {$IFDEF DARWIN} + if (length(Stack) mod 16) <> 0 then begin + Stack := Stack + StringOfChar(ansichar(#32), 16 - (Length(Stack) mod 16)) ; + end; + {$ENDIF} + if assigned(res) then begin + case res^.aType.BaseType of + btSingle: tbtsingle(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btDouble: tbtdouble(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btExtended: tbtextended(res^.Dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btChar, btU8, btS8: tbtu8(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.Dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); + btClass, btu32, bts32: tbtu32(res^.Dta^):= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + btPChar: pansichar(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + {$IFNDEF PS_NOINT64}bts64: + begin + EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); + tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX; + end; + {$ENDIF} + btVariant, + btInterface, btrecord, btstring: RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + else + exit; + end; + end else + RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + Result := True; + end; + cdSafeCall: begin + RegUsage := 3; + if assigned(res) then begin + GetPtr(res); + end; + for I := Params.Count - 1 downto 0 do begin + if not GetPtr(Params[i]) then Exit; + end; + if assigned(_Self) then begin + Stack := StringOfChar(AnsiChar(#0),4) +Stack; + Pointer((@Stack[1])^) := _Self; + end; + {$IFDEF DARWIN} + if (length(Stack) mod 16) <> 0 then begin + Stack := Stack + StringOfChar(ansichar(#32), 16 - (Length(Stack) mod 16)) ; + end; + {$ENDIF} + OleCheck(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + Result := True; + end; - {$IFDEF WINDOWS} - Registers.Stack := pp; - Registers.Items := Length(Stack) div 8; - x64call(Address, _RAX, _XMM0, Registers); - {$ELSE} - x64call(Address, _RAX, Registers, pp, Length(Stack) div 8, _XMM0); - {$ENDIF !WINDOWS} - end; // if else - Result := True; - finally - if Assigned(CallData) then begin - for i := CallData.Count-1 downto 0 do - begin - pp := CallData[i]; - case pp^ of - 0: begin - DestroyOpenArray(Self, Pointer(pp)); + CdCdecl: begin + RegUsage := 3; + if assigned(_Self) then begin + Stack := StringOfChar(AnsiChar(#0),4); + Pointer((@Stack[1])^) := _Self; + end; + for I := Params.Count - 1 downto 0 do begin + if not GetPtr(Params[I]) then Exit; + end; + {$IFDEF DARWIN} + if (length(Stack) mod 16) <> 0 then begin + Stack := Stack + StringOfChar(ansichar(#32), 16 - (Length(Stack) mod 16)) ; + end; + {$ENDIF} + if assigned(res) then begin + case res^.aType.BaseType of + btSingle: tbtsingle(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btDouble: tbtdouble(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btExtended: tbtextended(res^.dta^) := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btCHar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); + btClass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + btPChar: pansichar(res^.dta^) := Pansichar(RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + {$IFNDEF PS_NOINT64}bts64: + begin + EAX := RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); + tbts64(res^.Dta^) := Int64(EAX) shl 32 or EDX; + end; + {$ENDIF} + btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF} + btInterface, + btArray, btrecord, btstring: begin GetPtr(res); RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end; + else + exit; + end; + end else begin + RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); + end; + Result := True; + end; + CdStdCall: begin + RegUsage := 3; + for I := Params.Count - 1 downto 0 do begin + if not GetPtr(Params[I]) then exit; + end; + if assigned(_Self) then begin + Stack := StringOfChar(AnsiChar(#0),4) + Stack; + Pointer((@Stack[1])^) := _Self; end; - 255: begin - Dispose(PMethodCallData(pp)); // release TMethodCallData + if assigned(res) then begin + case res^.aType.BaseType of + btSingle: tbtsingle(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btDouble: tbtdouble(res^.dta^) := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btExtended: tbtextended(res^.dta^):= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4); + btChar, btU8, btS8: tbtu8(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil); + {$IFNDEF PS_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16: tbtu16(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil); + btclass, btu32, bts32: tbtu32(res^.dta^) := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil); + btPChar: pansichar(res^.dta^) := Pansichar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil)); + {$IFNDEF PS_NOINT64}bts64: + begin + EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX); + tbts64(res^.dta^) := Int64(EAX) shl 32 or EDX; + end; + {$ENDIF} + btVariant, {$IFNDEF PS_NOWIDESTRING}btUnicodeString, btWideString, {$ENDIF} + btInterface, btArray, btrecord, btstring: begin GetPtr(res); RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end; + else + exit; + end; + end else begin + RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end; + Result := True; end; + end; + finally + for i := CallData.Count -1 downto 0 do + begin + pp := CallData[i]; + case pp^ of + 0: DestroyOpenArray(Self, Pointer(pp)); end; - CallData.Free; end; + CallData.Free; end; end; From 809f623fa4fc1f91b19bdbdfaabd775de67119b2 Mon Sep 17 00:00:00 2001 From: Vadim Lou Date: Sat, 2 Mar 2019 09:46:22 +0200 Subject: [PATCH 5/9] Update x64.inc --- Source/x64.inc | 65 +++++++++++++++++++++++++++----------------------- 1 file changed, 35 insertions(+), 30 deletions(-) diff --git a/Source/x64.inc b/Source/x64.inc index f8cbc3c3..27eff2a9 100644 --- a/Source/x64.inc +++ b/Source/x64.inc @@ -944,6 +944,9 @@ var {$IFNDEF WINDOWS} RegUsageFloat: Byte; {$ENDIF} +{$IFDEF FPC} + IsConstructor,IsVirtualCons: Boolean; +{$ENDIF} RegUsage: Byte; CallData: TPSList; I: Integer; @@ -1090,9 +1093,6 @@ var end; PMethodCallData=^TMethodCallData; function GetPtr(fVar: PPSVariantIFC): Boolean; - // [#velter#]: https://github.com/remobjects/pascalscript/pull/107 - // https://github.com/velter/pascalscript/commit/44cefba3328bd9cc041e11715d217c97c97199e7 - // https://github.com/remobjects/pascalscript/pull/107/files#diff-0 var varPtr: Pointer; p: Pointer; @@ -1106,7 +1106,7 @@ var if Copy(fVar.aType.ExportName, 1, 10) = '!OPENARRAY' then begin p := CreateOpenArray(True, Self, fVar); if p = nil then exit; - if CallData = nil then // [#velter#] + if CallData = nil then CallData := TPSList.Create; CallData.Add(p); StoreReg(IPointer(POpenArray(p)^.Data)); @@ -1124,7 +1124,7 @@ var btRecord, btInterface, btClass, - {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar, {$ENDIF} btU8, btS8, btU16, + {$IFNDEF PS_NOWIDESTRING} btUnicodeString, btWideString, btWideChar,{$ENDIF} btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPChar, btChar, btCurrency {$IFNDEF PS_NOINT64}, bts64{$ENDIF}: begin Varptr := fVar.Dta; @@ -1150,7 +1150,7 @@ var if Copy(fVar.aType.ExportName, 1, 10) = '!OPENARRAY' then begin p := CreateOpenArray(False, Self, fVar); if p =nil then exit; - if CallData = nil then // [#velter#] + if CallData = nil then CallData := TPSList.Create; CallData.Add(p); StoreReg(IPointer(POpenArray(p)^.Data)); @@ -1206,24 +1206,13 @@ var StoreReg(IPointer(fVar.dta^)); end; btProcPtr: begin - // [#velter#]: - { - GetMem(p, PointerSize2); - TMethod(p^) := MKMethod(Self, Longint(fVar.Dta^)); - StoreStack(p^, Pointersize2); - FreeMem(p); - } - //GetMem(p, sizeof(TMethodCallData)); p := New(PMethodCallData); TMethodCallData(p^).AType:=255; if CallData = nil then CallData := TPSList.Create; CallData.Add(p); - TMethodCallData(p^).Data.Code:=nil; - //TMethodCallData(p^).Data.Data:=nil; TMethodCallData(p^).Data := MKMethod(Self, Longint(fVar.Dta^)); // It requires the implementation of "Handled" StoreReg(IPointer(@TMethodCallData(p^).Data)); - // [#velter#]. end; btS64: begin StoreReg(IPointer(int64(fVar.dta^))); @@ -1234,12 +1223,23 @@ var end; // function GetPtr begin // function TPSExec.InnerfuseCall - // TODO: FPC: OpenArray fail (AV). Sample script: "begin format('%s; %s',['2','2']); end." + {$IFDEF FPC} + if (Integer(CallingConv) and 128) <> 0 then begin + IsVirtualCons := true; + CAllingConv := TPSCallingConvention(Integer(CallingConv) and not 128); + end else + IsVirtualCons:= false; + if (Integer(CallingConv) and 64) <> 0 then begin + IsConstructor := true; + CAllingConv := TPSCallingConvention(Integer(CallingConv) and not 64); + end else + IsConstructor := false; + {$ENDIF} InnerfuseCall := False; if Address = nil then exit; // need address SetLength(Stack, 0); - CallData := nil; // [#velter#] + CallData := nil; res := rp(res); if res <> nil then res.VarParam := true; @@ -1257,6 +1257,15 @@ begin // function TPSExec.InnerfuseCall FillChar(Registers, Sizeof(Registers), 0); _RAX := 0; RegUsage := 0; + {$warnings off} + {$IF DEFINED (fpc) and (fpc_version >= 3)} // FIX FOR FPC constructor calls + {$warnings on} + if IsConstructor then begin + if not GetPtr(rp(Params[0])) then exit; // this goes first + DisposePPSVariantIFC(Params[0]); + Params.Delete(0); + end; + {$ENDIF} if assigned(_Self) then begin StoreReg(IPointer(_Self)); end; @@ -1274,10 +1283,7 @@ begin // function TPSExec.InnerfuseCall btString, {.$ENDIF} {$ENDIF x64_string_result_as_varparameter} - {$IFNDEF FPC} - btArray, - {$ENDIF} - btInterface, btVariant, btStaticArray: + btInterface, btArray, btVariant, btStaticArray: GetPtr(res); btRecord, btSet: @@ -1289,8 +1295,8 @@ begin // function TPSExec.InnerfuseCall end; {$ENDIF PS_RESBEFOREPARAMETERS} for I := 0 to Params.Count - 1 do begin - if not GetPtr(rp(Params[I])) then - Exit; + if not GetPtr(rp(Params[I])) then + Exit; end; if assigned(res) then begin {$IFNDEF PS_RESBEFOREPARAMETERS} @@ -1342,7 +1348,7 @@ begin // function TPSExec.InnerfuseCall tbtdouble(res.Dta^) := _XMM0; btExtended: tbtextended(res.Dta^) := _XMM0; - btchar,btU8, btS8: + btChar, btU8, btS8: tbtu8(res.dta^) := _RAX; {$IFNDEF PS_NOWIDESTRING} @@ -1352,7 +1358,7 @@ begin // function TPSExec.InnerfuseCall btClass : IPointer(res.dta^) := _RAX; - btu32,bts32: + btu32, bts32: tbtu32(res.dta^) := _RAX; btPChar: pansichar(res.dta^) := Pansichar(_RAX); @@ -1403,9 +1409,8 @@ begin // function TPSExec.InnerfuseCall 0: begin DestroyOpenArray(Self, Pointer(pp)); end; - 255: begin // [#velter#]: https://github.com/velter/pascalscript/commit/1c598a1406390e2e762368b07a185ecb187182a7 - //FreeMem(Pointer(pp), sizeof(TMethodCallData)); // release TMethodCallData - Dispose(PMethodCallData(pp)); + 255: begin + Dispose(PMethodCallData(pp)); // release TMethodCallData end; end; end; From 96ad2048e66f862e3aae51217078ad77b6c8e6e3 Mon Sep 17 00:00:00 2001 From: Vadim Lou Date: Sat, 21 Sep 2019 00:25:55 +0300 Subject: [PATCH 6/9] Update x64.inc --- Source/x64.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Source/x64.inc b/Source/x64.inc index 27eff2a9..8d1131bc 100644 --- a/Source/x64.inc +++ b/Source/x64.inc @@ -38,7 +38,7 @@ type {$ENDIF} {$ELSE !MSWINDOWS} - {$DEFINE X64CALL_ASM} { optional } // TODO: Check pas version (disable "X64CALL_ASM"). + {.$DEFINE X64CALL_ASM} { optional } // TODO: Check pas version (disable "X64CALL_ASM"). {$ENDIF !MSWINDOWS} From 3f09d8a7fa5ed12fbb23e1d203e57421bd40fe06 Mon Sep 17 00:00:00 2001 From: Vadim Lou Date: Tue, 31 Dec 2019 17:05:55 +0200 Subject: [PATCH 7/9] Update x64.inc --- Source/x64.inc | 138 ++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 119 insertions(+), 19 deletions(-) diff --git a/Source/x64.inc b/Source/x64.inc index 8d1131bc..2d0db7eb 100644 --- a/Source/x64.inc +++ b/Source/x64.inc @@ -30,7 +30,7 @@ type {$ENDIF} {$IFDEF FPC} - {.$DEFINE X64CALL_ASM} { optional } // ! Not recomended : GPF on exception ! + {$DEFINE X64CALL_ASM} { optional } // ! Not recomended : GPF on exception ! // TODO: need test ... {$ENDIF} {$ELSE} @@ -201,8 +201,56 @@ type t_pcall_66 = procedure(_rcx,_rdx,_r8,_r9,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18,p19,p20, p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63,p64,p65,p66: IPointer); + procedure x64call({RCX}Address: Pointer;out {RDX}_RAX: IPointer;var {R8}_XMM0: Double; var {R9}R: TRegisters); + + function get_rax: IPointer; assembler; + asm + //-mov Result, rax // !Not necessarily! + end; + function get_xmm0: Double; assembler; + asm + movsd Result, xmm0 + end; + + procedure set_rax(var _RAX: Double); assembler; + asm + mov rax, _RAX + end; + procedure set_xmm1; assembler; + asm + movsd xmm1, [rax] + end; + procedure set_xmm2; assembler; + asm + movsd xmm2, [rax] + end; + procedure set_xmm3; assembler; + asm + movsd xmm3, [rax] + end; + procedure set_xmm0; assembler; + asm + movsd xmm0, [rax] + end; + begin + // xmm1: + set_rax(R._XMM1); + set_xmm1(); + + // xmm2: + set_rax(R._XMM2); + set_xmm2(); + + // xmm3: + set_rax(R._XMM3); + set_xmm3(); + + // xmm0: + set_rax(_XMM0); + set_xmm0(); + case R.Items of // stack items count 00: t_pcall_04(Address)(R._RCX,R._RDX,R._R8,R._R9); 01: t_pcall_05(Address)(R._RCX,R._RDX,R._R8,R._R9,R.S[00]); @@ -456,7 +504,10 @@ begin //} else raise EInvocationError.Create('Internal: Parameter count exceeded 64'); - end; + end; // case + // + _RAX := get_rax(); + _XMM0 := get_xmm0(); end; {$ENDIF} @@ -538,13 +589,13 @@ asm sub rsp, $210 mov rbp, rsp {$endif} - - mov [rbp+c_loc_offs_adress], Address // save: rcx (@Address) - mov [rbp+c_loc_offs__rax], _RAX // save: rdx (@_RDX) - mov [rbp+c_loc_offs__xmm0], _XMM0 // save: r8 (@_XMM0) - mov [rbp+c_loc_offs_reginfo], RegInfo // save: r9 (@RegInfo) dbg: TRegisters(pointer(R9)^),r - - // + // dbg: in: TRegisters(pointer(R9)^),r + mov [rbp+c_loc_offs_adress], Address // save: rcx (@Address) dbg: loc: qword(pointer(rbp+c_loc_offs_adress)^) ; in: qword(pointer(RCX)) + mov [rbp+c_loc_offs__rax], _RAX // save: rdx (@_RDX) dbg: loc: qword(pointer(rbp+c_loc_offs__rax)^) ; in: qword(pointer(RDX)) + mov [rbp+c_loc_offs__xmm0], _XMM0 // save: r8 (@_XMM0) dbg: loc: qword(pointer(rbp+c_loc_offs__xmm0)^) ; in: qword(pointer(R8)) + mov [rbp+c_loc_offs_reginfo], RegInfo // save: r9 (@RegInfo) dbg: loc: qword(pointer(rbp+c_loc_offs_reginfo)^) ; in: qword(pointer(R9)) + // dbg: TRegisters(pointer(pointer(rbp+c_loc_offs_reginfo)^)^),r + // dbg: tdatetime(pointer(pointer(rbp+c_loc_offs__xmm0)^)^) // check Registers.Items (param count limitation) // mov rcx, [RegInfo].TRegisters.Items @@ -582,27 +633,76 @@ asm @@skip_items: + // copy registers + + //{ #1 + movsd xmm1,[RegInfo].TRegisters._XMM1 + movsd xmm2,[RegInfo].TRegisters._XMM2 + movsd xmm3,[RegInfo].TRegisters._XMM3 + + // _XMM0 => xmm0 + mov rax, [rbp+c_loc_offs__xmm0] // dbg: tdatetime(pointer(pointer(rbp+c_loc_offs__xmm0)^)^) + movsd xmm0,[rax] // dbg: tdatetime(pointer(pointer(xmm0))^) + //} + + { #2: handle SingleBits + mov rcx, [RegInfo + offset(TRegisters.SingleBits)] + + // fill: _XMM1 + bt rcx, 1 + jnc @g1 + cvtsd2ss xmm1, [RegInfo + offset(TRegisters._XMM1)] + jmp @g1e + @g1: + movsd xmm1, [RegInfo + offset(TRegisters._XMM1)] + @g1e: + + // fill: _XMM2 + bt rcx, 2 + jnc @g2 + cvtsd2ss xmm2, [RegInfo + offset(TRegisters._XMM2)] + jmp @g2e + @g2: + movsd xmm2, [RegInfo + offset(TRegisters._XMM2)] + @g2e: + + // fill: _XMM3 + bt rcx, 3 + jnc @g3 + cvtsd2ss xmm3, [RegInfo + offset(TRegisters._XMM3)] + jmp @g3e + @g3: + movsd xmm3, [RegInfo + offset(TRegisters._XMM3)] + @g3e: + + // fill: _XMM0 + bt rcx, 0 + jnc @g0 + mov rdx, [rbp+c_loc_offs__xmm0] + cvtsd2ss xmm0, [rdx] + jmp @g0e + @g0: + mov rdx, [rbp+c_loc_offs__xmm0] + movsd xmm0, [rdx] + @g0e: + //} + // mov *, [r9].* ; [r9] == [RegInfo] mov rcx, [RegInfo].TRegisters._RCX mov rdx, [RegInfo].TRegisters._RDX mov r8, [RegInfo].TRegisters._R8 - movsd xmm0,[RegInfo].TRegisters._RCX - movsd xmm1,[RegInfo].TRegisters._RDX - movsd xmm2,[RegInfo].TRegisters._R8 - movsd xmm3,[RegInfo].TRegisters._R9 - mov r9, [RegInfo].TRegisters._R9 // !!! Overwritten RegInfo (r9) call [rbp+c_loc_offs_adress] // make result mov rdx, [rbp+c_loc_offs__rax] // restore: rdx (@_RDX) - mov [rdx], RAX // fill: _RAX + mov [rdx], RAX // fill: _RAX //movsd [rdx+c_sz_ptr], XMM0 // fill: _XMM0 mov rdx, [rbp+c_loc_offs__xmm0] // restore: r8 (@_RMM0) - mov [rdx], RAX // fill: _RAX + movsd [rdx], XMM0 // fill: _XMM0 // @dbg: TRegisters(pointer(pointer(rbp+c_loc_offs_reginfo)^)^),r {$ifdef DELPHI} {$else} @@ -1265,7 +1365,7 @@ begin // function TPSExec.InnerfuseCall DisposePPSVariantIFC(Params[0]); Params.Delete(0); end; - {$ENDIF} + {$IFEND} if assigned(_Self) then begin StoreReg(IPointer(_Self)); end; @@ -1326,7 +1426,7 @@ begin // function TPSExec.InnerfuseCall {$IFDEF WINDOWS} Registers.Stack := pp; Registers.Items := Length(Stack) div 8; - x64call(Address, _RAX, _XMM0, Registers); + x64call({RCX}Address, {RDX: out IPointer:}_RAX, {R8: var Double:}_XMM0, {R9: var TRegisters:}Registers); {$ELSE} x64call(Address, _RAX, Registers, pp, Length(Stack) div 8, _XMM0); {$ENDIF !WINDOWS} @@ -1345,7 +1445,7 @@ begin // function TPSExec.InnerfuseCall btSingle: tbtsingle(res.Dta^) := _XMM0; btDouble: - tbtdouble(res.Dta^) := _XMM0; + tbtdouble(res.Dta^) := _XMM0; // @dbg: TDateTime(res.Dta^) TDateTime(_XMM0) btExtended: tbtextended(res.Dta^) := _XMM0; btChar, btU8, btS8: From 9ae93e306f778bc58cb6f7d1d107cdaf8d43e11c Mon Sep 17 00:00:00 2001 From: Vadim Lou Date: Tue, 31 Dec 2019 17:24:20 +0200 Subject: [PATCH 8/9] Update x64.inc --- Source/x64.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Source/x64.inc b/Source/x64.inc index 2d0db7eb..51fc4a56 100644 --- a/Source/x64.inc +++ b/Source/x64.inc @@ -30,7 +30,7 @@ type {$ENDIF} {$IFDEF FPC} - {$DEFINE X64CALL_ASM} { optional } // ! Not recomended : GPF on exception ! // TODO: need test ... + {.$DEFINE X64CALL_ASM} { optional } // ! Not recomended : GPF on exception ! // TODO: need test ... {$ENDIF} {$ELSE} From 508f243ede3745f59147fcdd43aca121730362d6 Mon Sep 17 00:00:00 2001 From: Vadim Lou Date: Wed, 1 Jan 2020 01:35:02 +0200 Subject: [PATCH 9/9] Update x64.inc --- Source/x64.inc | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/Source/x64.inc b/Source/x64.inc index 51fc4a56..ed072e4b 100644 --- a/Source/x64.inc +++ b/Source/x64.inc @@ -202,34 +202,39 @@ type p21,p22,p23,p24,p25,p26,p27,p28,p29,p30,p31,p32,p33,p34,p35,p36,p37,p38,p39,p40, p41,p42,p43,p44,p45,p46,p47,p48,p49,p50,p51,p52,p53,p54,p55,p56,p57,p58,p59,p60,p61,p62,p63,p64,p65,p66: IPointer); + {$IFDEF FPC} + {$mode delphi} + {$ASMMODE INTEL} + {$ENDIF} + procedure x64call({RCX}Address: Pointer;out {RDX}_RAX: IPointer;var {R8}_XMM0: Double; var {R9}R: TRegisters); - function get_rax: IPointer; assembler; + function get_rax: IPointer; assembler; {$ifdef FPC}nostackframe;{$endif} asm //-mov Result, rax // !Not necessarily! end; - function get_xmm0: Double; assembler; + function get_xmm0: Double; assembler; {$ifdef FPC}nostackframe;{$endif} asm movsd Result, xmm0 end; - procedure set_rax(var _RAX: Double); assembler; + procedure set_rax(var _RAX: Double); assembler; {$ifdef FPC}nostackframe;{$endif} asm mov rax, _RAX end; - procedure set_xmm1; assembler; + procedure set_xmm1; assembler; {$ifdef FPC}nostackframe;{$endif} asm movsd xmm1, [rax] end; - procedure set_xmm2; assembler; + procedure set_xmm2; assembler; {$ifdef FPC}nostackframe;{$endif} asm movsd xmm2, [rax] end; - procedure set_xmm3; assembler; + procedure set_xmm3; assembler; {$ifdef FPC}nostackframe;{$endif} asm movsd xmm3, [rax] end; - procedure set_xmm0; assembler; + procedure set_xmm0; assembler; {$ifdef FPC}nostackframe;{$endif} asm movsd xmm0, [rax] end;