1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-12-05 07:02:16 -05:00
Simba/trunk/Projects/PStest/unit1.pas

182 lines
5.3 KiB
ObjectPascal
Raw Normal View History

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.