mirror of
https://github.com/moparisthebest/Simba
synced 2024-12-05 15:12:19 -05:00
182 lines
5.3 KiB
ObjectPascal
182 lines
5.3 KiB
ObjectPascal
|
unit Unit1;
|
||
|
|
||
|
{$mode objfpc}{$H+}
|
||
|
|
||
|
interface
|
||
|
|
||
|
uses
|
||
|
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
|
||
|
StdCtrls, uPSComponent, uPSCompiler, uPSRuntime,UPSUtils,testps;
|
||
|
|
||
|
type
|
||
|
|
||
|
{ TForm1 }
|
||
|
|
||
|
TForm1 = class(TForm)
|
||
|
Button1: TButton;
|
||
|
Memo1: TMemo;
|
||
|
Memo2: TMemo;
|
||
|
procedure Button1Click(Sender: TObject);
|
||
|
procedure Memo1Change(Sender: TObject);
|
||
|
procedure ScriptCompile(Sender: TPSScript);
|
||
|
procedure ScriptCompImport(Sender: TObject; x: TPSPascalCompiler);
|
||
|
procedure ScriptExecImport(Sender: TObject; se: TPSExec;
|
||
|
x: TPSRuntimeClassImporter);
|
||
|
private
|
||
|
{ private declarations }
|
||
|
public
|
||
|
{ public declarations }
|
||
|
end;
|
||
|
|
||
|
var
|
||
|
Form1: TForm1;
|
||
|
|
||
|
implementation
|
||
|
|
||
|
|
||
|
uses
|
||
|
uPSR_std,
|
||
|
uPSC_std,
|
||
|
uPSR_stdctrls,
|
||
|
uPSC_stdctrls,
|
||
|
uPSR_forms,
|
||
|
uPSC_forms,
|
||
|
uPSC_graphics,
|
||
|
uPSC_controls,
|
||
|
uPSC_classes,
|
||
|
uPSR_graphics,
|
||
|
uPSR_controls,
|
||
|
uPSR_classes;
|
||
|
{ TForm1 }
|
||
|
|
||
|
procedure TForm1.Button1Click(Sender: TObject);
|
||
|
var
|
||
|
Script : TPSScript;
|
||
|
procedure OutputMessages;
|
||
|
var
|
||
|
l: Longint;
|
||
|
b: Boolean;
|
||
|
begin
|
||
|
b := False;
|
||
|
|
||
|
for l := 0 to Script.CompilerMessageCount - 1 do
|
||
|
begin
|
||
|
Memo2.Lines.Add('Compiler: '+ Script.CompilerErrorToStr(l));
|
||
|
if (not b) and (Script.CompilerMessages[l] is TIFPSPascalCompilerError) then
|
||
|
begin
|
||
|
b := True;
|
||
|
Memo1.SelStart := Script.CompilerMessages[l].Pos;
|
||
|
end;
|
||
|
end;
|
||
|
end;
|
||
|
begin
|
||
|
Script := TPSScript.Create(self);
|
||
|
Script.OnCompImport:=@ScriptCompImport;
|
||
|
Script.OnExecImport:=@ScriptExecImport;
|
||
|
Script.OnCompile:=@ScriptCompile;
|
||
|
Memo2.Lines.Clear;
|
||
|
Script.Script.Assign(Memo1.Lines);
|
||
|
Memo2.Lines.Add('Compiling');
|
||
|
if Script.Compile then
|
||
|
begin
|
||
|
OutputMessages;
|
||
|
Memo2.Lines.Add('Compiled succesfully');
|
||
|
if not Script.Execute then
|
||
|
begin
|
||
|
Memo1.SelStart := Script.ExecErrorPosition;
|
||
|
Memo2.Lines.Add(Script.ExecErrorToString +' at '+Inttostr(Script.ExecErrorProcNo)+'.'+Inttostr(Script.ExecErrorByteCodePosition));
|
||
|
end else Memo2.Lines.Add('Succesfully executed');
|
||
|
end else
|
||
|
begin
|
||
|
OutputMessages;
|
||
|
Memo2.Lines.Add('Compiling failed');
|
||
|
end;
|
||
|
Script.free;
|
||
|
end;
|
||
|
|
||
|
procedure TForm1.Memo1Change(Sender: TObject);
|
||
|
begin
|
||
|
|
||
|
end;
|
||
|
|
||
|
|
||
|
|
||
|
function teststdcall(num1,num2,num3,num4,num5,num6 : LongInt) : boolean; stdcall;
|
||
|
begin;
|
||
|
Result := false;
|
||
|
Form1.Memo2.Lines.add(Format('stdcall AddFunctionEx: %d %d %d %d %d %d',[num1,num2,num3,num4,num5,num6]));
|
||
|
end;
|
||
|
|
||
|
function testcdecl(num1,num2,num3,num4,num5,num6 : LongInt) : boolean; cdecl;
|
||
|
begin;
|
||
|
Result := false;
|
||
|
Form1.Memo2.Lines.add(Format('cdecl AddFunctionEx: %d %d %d %d %d %d',[num1,num2,num3,num4,num5,num6]));
|
||
|
end;
|
||
|
|
||
|
|
||
|
function testnormal(num1,num2,num3,num4,num5,num6 : LongInt) : boolean;
|
||
|
begin;
|
||
|
Result := false;
|
||
|
Form1.Memo2.Lines.add(Format('Normal AddFunction: %d %d %d %d %d %d',[num1,num2,num3,num4,num5,num6]));
|
||
|
end;
|
||
|
|
||
|
function DiffTest(num : integer; str : string; byt : byte; wor : longword; bool : boolean) : boolean;
|
||
|
begin;
|
||
|
Result := false;
|
||
|
Form1.Memo2.Lines.add(inttostr(num) + '-' + str +'-' + inttostr(byt) +'-' + inttostr(wor) +'-' + booltostr(bool,true));
|
||
|
end;
|
||
|
|
||
|
|
||
|
procedure TForm1.ScriptCompImport(Sender: TObject; x: TPSPascalCompiler);
|
||
|
begin
|
||
|
SIRegister_Std(x);
|
||
|
SIRegister_Classes(x, true);
|
||
|
SIRegister_Graphics(x, true);
|
||
|
SIRegister_Controls(x);
|
||
|
SIRegister_stdctrls(x);
|
||
|
SIRegister_Forms(x);
|
||
|
end;
|
||
|
|
||
|
procedure TForm1.ScriptExecImport(Sender: TObject; se: TPSExec;
|
||
|
x: TPSRuntimeClassImporter);
|
||
|
begin
|
||
|
RIRegister_Std(x);
|
||
|
RIRegister_Classes(x, True);
|
||
|
RIRegister_Graphics(x, True);
|
||
|
RIRegister_Controls(x);
|
||
|
RIRegister_stdctrls(x);
|
||
|
RIRegister_Forms(x);
|
||
|
end;
|
||
|
|
||
|
procedure Writeln(s : string);
|
||
|
begin;
|
||
|
Form1.Memo2.Lines.add(s);
|
||
|
end;
|
||
|
|
||
|
procedure TForm1.ScriptCompile(Sender: TPSScript);
|
||
|
begin
|
||
|
Sender.Comp.AddTypeS('TStringArray','Array of string');
|
||
|
Sender.Comp.AddTypeS('w_TPoint', 'record x, y: integer; end;');
|
||
|
Sender.AddFunction(@Writeln,'procedure writeln(s:string)');
|
||
|
Sender.AddFunction(@testnormal,'function testnormal(num1,num2,num3,num4,num5,num6 : LongInt) : boolean;');
|
||
|
Sender.AddFunctionEx(@teststdcall, 'function teststdcall(num1,num2,num3,num4,num5,num6 : LongInt) : boolean;stdcall;',cdStdCall);
|
||
|
Sender.AddFunctionEx(@testcdecl, 'function testcdecl(num1,num2,num3,num4,num5,num6 : LongInt) : boolean; cdecl;',cdCdecl);
|
||
|
Sender.AddFunction(@DiffTest,'function DiffTest(num : integer; str : string; byt : byte; wor : longword; bool : boolean) : boolean;');
|
||
|
Sender.AddFunction(@TestParameters,'procedure TestParameters(Int1,Int2,Int3,Int4,Int5,Int6 : integer);');
|
||
|
Sender.AddFunction(@TestResult,'function TestResult(Int1,Int2,Int3,Int4,Int5,Int6 : integer): Integer;');
|
||
|
Sender.AddFunction(@TestString,'function TestString(Str1,Str2,Str3 : string) : string;');
|
||
|
Sender.AddFunction(@TestStringEdit,'function TestStringEdit(var Str : string) : String;');
|
||
|
Sender.AddFunction(@TestArrayPassing,'procedure TestArrayPassing(const Arr : TStringArray);');
|
||
|
Sender.AddFunction(@TestArrayEdit,'Procedure TestArrayEdit(var Arr : TStringArray);');
|
||
|
Sender.AddFunction(@TestArrayFull,'function TestArrayFull(var Arr1: TStringArray; Arr2 : TStringArray): TStringArray;');
|
||
|
Sender.AddFunction(@MakeArr,'function MakeArr : TStringArray;');
|
||
|
Sender.AddFunction(@makePoint, 'function makePoint(x, y: integer): w_Tpoint;');
|
||
|
end;
|
||
|
|
||
|
|
||
|
initialization
|
||
|
{$I unit1.lrs}
|
||
|
|
||
|
end.
|
||
|
|