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 00000000..f7255606 Binary files /dev/null and b/Samples/console_rops/console_rops.res differ diff --git a/Samples/console_rops/console_rops_test_fp64.inc b/Samples/console_rops/console_rops_test_fp64.inc new file mode 100644 index 00000000..e101d2a6 --- /dev/null +++ b/Samples/console_rops/console_rops_test_fp64.inc @@ -0,0 +1,100 @@ +{ console_rops_test_fp64.inc } + +function fp64_decl: tbtString; +var s: tbtString; +begin + s := 'function fp64('; + s := s + 'p1:string; p2:string; p3:string; p4:string; p5:string; p6:string; p7:string; p8:string; '; + s := s + 'p9:string; p10:string; p11:string; p12:string; p13:string; p14:string; p15:string; '; + s := s + 'p16:string; p17:string; p18:string; p19:string; p20:string; p21:string; p22:string; '; + s := s + 'p23:string; p24:string; p25:string; p26:string; p27:string; p28:string; p29:string; '; + s := s + 'p30:string; p31:string; p32:string; p33:string; p34:string; p35:string; p36:string; '; + s := s + 'p37:string; p38:string; p39:string; p40:string; p41:string; p42:string; p43:string; '; + s := s + 'p44:string; p45:string; p46:string; p47:string; p48:string; p49:string; p50:string; '; + s := s + 'p51:string; p52:string; p53:string; p54:string; p55:string; p56:string; p57:string; '; + s := s + 'p58:string; p59:string; p60:string; p61:string; p62:string; p63:string; '; + s := s + 'var p64:string'; + s := s + '): string'; + Result := s; +end; + +function script_fp64( + // x.AddDelphiFunction(fp64_decl()); + // Sender.Exec.RegisterDelphiFunction(@script_fp64, 'fp64', cdRegister); + p1: string; + p2: string; + p3: string; + p4: string; + p5: string; + p6: string; + p7: string; + p8: string; + p9: string; + p10: string; + p11: string; + p12: string; + p13: string; + p14: string; + p15: string; + p16: string; + p17: string; + p18: string; + p19: string; + p20: string; + p21: string; + p22: string; + p23: string; + p24: string; + p25: string; + p26: string; + p27: string; + p28: string; + p29: string; + p30: string; + p31: string; + p32: string; + p33: string; + p34: string; + p35: string; + p36: string; + p37: string; + p38: string; + p39: string; + p40: string; + p41: string; + p42: string; + p43: string; + p44: string; + p45: string; + p46: string; + p47: string; + p48: string; + p49: string; + p50: string; + p51: string; + p52: string; + p53: string; + p54: string; + p55: string; + p56: string; + p57: string; + p58: string; + p59: string; + p60: string; + p61: string; + p62: string; + p63: string; + var p64: string +): string; +begin + p64 := 'var:('+p64+')'; + Result := 'fp64'; +end; + +{procedure fp64_test(); +var r,p64: string; +begin + p64 := '!p64!'; + r := script_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;//} diff --git a/Samples/console_rops/ide.zip b/Samples/console_rops/ide.zip new file mode 100644 index 00000000..0ea5fae1 Binary files /dev/null and b/Samples/console_rops/ide.zip differ 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. 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..ed072e4b 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,522 @@ { 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 ! // TODO: need test ... + {$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); + + {$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; {$ifdef FPC}nostackframe;{$endif} + asm + //-mov Result, rax // !Not necessarily! + end; + function get_xmm0: Double; assembler; {$ifdef FPC}nostackframe;{$endif} + asm + movsd Result, xmm0 + end; + + procedure set_rax(var _RAX: Double); assembler; {$ifdef FPC}nostackframe;{$endif} + asm + mov rax, _RAX + end; + procedure set_xmm1; assembler; {$ifdef FPC}nostackframe;{$endif} + asm + movsd xmm1, [rax] + end; + procedure set_xmm2; assembler; {$ifdef FPC}nostackframe;{$endif} + asm + movsd xmm2, [rax] + end; + procedure set_xmm3; assembler; {$ifdef FPC}nostackframe;{$endif} + asm + movsd xmm3, [rax] + end; + procedure set_xmm0; assembler; {$ifdef FPC}nostackframe;{$endif} + 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]); + 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; // case + // + _RAX := get_rax(); + _XMM0 := get_xmm0(); +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 +534,205 @@ 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 -procedure x64call( + 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} + // 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 + 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: + + // 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 + + 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) + movsd [rdx], XMM0 // fill: _XMM0 // @dbg: TRegisters(pointer(pointer(rbp+c_loc_offs_reginfo)^)^),r + +{$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 +782,6 @@ asm movsd xmm1, [rax+32] @g1e: - bt rcx, 2 jnc @g2 cvtsd2ss xmm2, [rax+40] @@ -94,8 +798,6 @@ asm movsd xmm3, [rax+48] @g3e: - - // rbp-16: address of xmm0 bt rcx, 0 @@ -114,12 +816,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 +849,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 +877,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 +913,9 @@ asm @work: {$IFDEF FPC} push qword ptr [rcx] -{$ELSE} +{$ELSE} push [rcx] -{$ENDIF} +{$ENDIF} dec r8 sub rcx,8 @compareitems: @@ -279,7 +987,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 +996,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 +1009,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 +1029,6 @@ asm movq [rsi],xmm0 // move quadword to _XMM0 @skipresre: - pop rdx pop r9 // xmm0 pop rsi // _rax @@ -330,16 +1036,21 @@ 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} +{$IFDEF FPC} + IsConstructor,IsVirtualCons: Boolean; {$ENDIF} RegUsage: Byte; CallData: TPSList; @@ -348,19 +1059,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 +1081,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 +1097,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 +1119,7 @@ _XMM0: Double; Move(aData, p^, Len); end; -{$IFDEF WINDOWS} + {$IFDEF WINDOWS} procedure StoreReg(data: Double); overload; var p: Pointer; begin @@ -418,11 +1128,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 +1143,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 +1163,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 +1182,45 @@ _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; 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)); Result := True; Exit; end else begin - varptr := fvar.Dta; -// Exit; + varptr := fVar.Dta; + //Exit; end; end; btVariant, @@ -514,125 +1229,122 @@ _XMM0: Double; 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 -// 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 + 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 - GetMem(p, PointerSize2); - TMethod(p^) := MKMethod(Self, Longint(FVar.Dta^)); - StoreStack(p^, Pointersize2); - FreeMem(p); + 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^))); 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 + {$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 := TPSList.Create; + CallData := nil; res := rp(res); if res <> nil then res.VarParam := true; @@ -646,38 +1358,53 @@ begin _XMM7 := 0;*) RegUsageFloat := 0; {$ENDIF} - _XMM0 := 0; - FillChar(Registers, Sizeof(REgisters), 0); + _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; + {$IFEND} 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} - 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} + btInterface, btArray, 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 +1414,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} + 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} + {$ENDIF !WINDOWS} + case res^.aType.BaseType of btRecord, btSet: begin @@ -715,54 +1447,79 @@ 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; // @dbg: TDateTime(res.Dta^) TDateTime(_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 + Dispose(PMethodCallData(pp)); // release TMethodCallData + end; + end; end; + CallData.Free; end; - CallData.Free; end; end; - - diff --git a/Source/x86.inc b/Source/x86.inc index 0b697751..5475ba05 100644 --- a/Source/x86.inc +++ b/Source/x86.inc @@ -30,7 +30,7 @@ begin end; Result := E; end; - + function RealFloatCall_Other(p: Pointer; StackData: Pointer; StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes) @@ -570,7 +570,7 @@ begin if (length(Stack) mod 16) <> 0 then begin Stack := Stack + StringOfChar(ansichar(#32), 16 - (Length(Stack) mod 16)) ; end; - {$ENDIF} + {$ENDIF} case res^.aType.BaseType of btSet: begin @@ -626,9 +626,9 @@ begin if (length(Stack) mod 16) <> 0 then begin Stack := Stack + StringOfChar(ansichar(#32), 16 - (Length(Stack) mod 16)) ; end; - {$ENDIF} + {$ENDIF} RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); - end; + end; Result := True; end; cdPascal: begin @@ -781,4 +781,3 @@ begin CallData.Free; end; end; -