mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-22 09:39:31 +02:00
PascalScript: port of the original tests
git-svn-id: trunk@39479 -
This commit is contained in:
martin
parent
51a6157180
commit
03b80bc7f6
6
.gitattributes
vendored
6
.gitattributes
vendored
@ -177,6 +177,12 @@ components/PascalScript/Source/uROPSImports.pas svneol=native#text/pascal
|
||||
components/PascalScript/Source/uROPSServerLink.pas svneol=native#text/pascal
|
||||
components/PascalScript/Source/x64.inc svneol=native#text/pascal
|
||||
components/PascalScript/Source/x86.inc svneol=native#text/pascal
|
||||
components/PascalScript/dunit/CompileTestExtended.pas svneol=native#text/pascal
|
||||
components/PascalScript/dunit/CompilerTestBase.pas svneol=native#text/pascal
|
||||
components/PascalScript/dunit/CompilerTestFunctions.pas svneol=native#text/pascal
|
||||
components/PascalScript/dunit/CompilerTestSimple.pas svneol=native#text/pascal
|
||||
components/PascalScript/dunit/ifps3.lpi svneol=native#text/pascal
|
||||
components/PascalScript/dunit/ifps3.lpr svneol=native#text/pascal
|
||||
components/README.txt svneol=native#text/plain
|
||||
components/aarre/src/aarrebase.lpk svneol=native#text/plain
|
||||
components/aarre/src/aarrebase.pas svneol=native#text/plain
|
||||
|
||||
145
components/PascalScript/dunit/CompileTestExtended.pas
Normal file
145
components/PascalScript/dunit/CompileTestExtended.pas
Normal file
@ -0,0 +1,145 @@
|
||||
unit CompileTestExtended;
|
||||
|
||||
interface
|
||||
|
||||
uses Classes,
|
||||
//TestFramework,
|
||||
{ Project Units }
|
||||
SysUtils,
|
||||
//ifps3,
|
||||
//ifps3utl,
|
||||
//ifpscomp,
|
||||
//IFPS3CompExec,
|
||||
CompilerTestBase, uPSCompiler, uPSUtils, testregistry;
|
||||
|
||||
type
|
||||
TCompilerTestExtended = class(TCompilerTestBase)
|
||||
private
|
||||
protected
|
||||
LastResult: string;
|
||||
LastResultB: Boolean;
|
||||
LastResultI: Longint;
|
||||
LastResultD: Double;
|
||||
procedure OnCompImport(Sender: TObject; x: TIFPSPascalCompiler); override;
|
||||
procedure ResultD(const d: Double);
|
||||
procedure ResultS(const s: string);
|
||||
procedure ResultB(const val: Boolean);
|
||||
procedure ResultI(const val: Longint);
|
||||
published
|
||||
procedure VariantTest1;
|
||||
procedure VariantTest2;
|
||||
procedure ArrayTest1;
|
||||
procedure CompileDouble;
|
||||
procedure ArrayRefCounting;
|
||||
procedure ArrayTest;
|
||||
procedure FormatTest;
|
||||
procedure ExtCharTest;
|
||||
procedure StrList;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
{ TCompilerTestExtended }
|
||||
|
||||
procedure TCompilerTestExtended.ArrayRefCounting;
|
||||
begin
|
||||
CompileRun('var e, d: array of string; begin SetArrayLength(d, 1); d[0] := ''123''; e := d;'+
|
||||
'setarraylength(d, 0); e[0] := ''321''; d := e;setarraylength(e, 0); d[0] := ''321'';end.');
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.ArrayTest;
|
||||
begin
|
||||
CompileRun('var d,e: array of string; begin SetArrayLength(d, 1); d[0] := ''123''; e := d; setarraylength(e, 0); ResultS(d[0]); end.');
|
||||
CheckEquals(LastResult, '123');
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.ArrayTest1;
|
||||
begin
|
||||
CompileRun('type Tstrarr = array of string; var r: TStrArr; i: Longint; Begin'+
|
||||
' setarraylength(r, 3); r[0] := ''asdf''; r[1] := ''safasf''; ResultS(r[0]+''!''+r[1]); end.');
|
||||
CheckEquals('asdf!safasf', LastResult);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.CompileDouble;
|
||||
var
|
||||
d: double;
|
||||
begin
|
||||
CompileRun('var x: Double; begin x := 1234.54656456; ResultS(Format(''%15.0f'',[2*x]));end.');
|
||||
d := 1234.54656456;
|
||||
CheckEquals(LastResult, Format('%15.0f',[2*d]));
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.ExtCharTest;
|
||||
var
|
||||
d: double;
|
||||
begin
|
||||
CompileRun('var s:string; i:integer; Res: Double; function Test(i1, i2: Integer): Double; begin Result := Double(i1) / i2; end; '+
|
||||
'begin i := ord(''a'');s:=chr(i); i := ord(''a''); s:= chr(i + 1); s := s + chr(i); res := Test(10, 2); ResultS(''Test 1: ''+s+''|Test 2:''+FloatToStr(res));end.');
|
||||
d := 10;
|
||||
d := d / 2;
|
||||
CheckEquals('Test 1: ba|Test 2:'+uPSUtils.FloatToStr(d), LastResult);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.FormatTest;
|
||||
begin
|
||||
CompileRun('var s: string; begin s := ''TeSTDaTa''; ResultS(''Test: ''+format(''test %s %f'', [s, 2 * PI])); end.');
|
||||
CheckEquals('Test: test TeSTDaTa '+SysUtils.Format('%f', [2*pi]), LastResult);
|
||||
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.OnCompImport(Sender: TObject;
|
||||
x: TIFPSPascalCompiler);
|
||||
begin
|
||||
inherited;
|
||||
CompExec.AddMethod(Self, @TCompilerTestExtended.ResultS, 'procedure ResultS(const s: string);');
|
||||
CompExec.AddMethod(Self, @TCompilerTestExtended.ResultB, 'procedure ResultB(const b: Boolean);');
|
||||
CompExec.AddMethod(Self, @TCompilerTestExtended.ResultI, 'procedure ResultI(const I: Longint);');
|
||||
CompExec.AddMethod(Self, @TCompilerTestExtended.ResultD, 'procedure ResultD(const D: Double);');
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.ResultB(const val: Boolean);
|
||||
begin
|
||||
LastResultB := Val;
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.ResultD(const d: Double);
|
||||
begin
|
||||
LastResultD := d;
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.ResultI(const val: Integer);
|
||||
begin
|
||||
LastResultI := Val;
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.ResultS(const s: string);
|
||||
begin
|
||||
LastResult := s;
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.StrList;
|
||||
begin
|
||||
CompileRun('var r: TStringList; begin r := TStringList.Create; try r.Values[''test''] := ''data'';'+
|
||||
'ResultS(''Test1: ''+r.Values[''test1'']+#13#10+''Test2: ''+r.Values[''test'']); finally r.Free; end;end.');
|
||||
|
||||
CheckEquals('Test1: '#13#10'Test2: data', Lastresult);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.VariantTest1;
|
||||
begin
|
||||
CompileRun('var v: variant; Begin v := ''Hey:''; v := v + FloatToStr(Pi); ResultS(v);end.');
|
||||
CheckEquals('Hey:'+uPSUtils.FloatToStr(Pi), LastResult);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestExtended.VariantTest2;
|
||||
begin
|
||||
CompileRun('var v: variant; s: string;Begin v := 123; s := v; v := s + ''_test_'';'+
|
||||
' s := v; v := 123.456; s := s + v; v := ''test'' + s; ResultS(v);end.');
|
||||
CheckEquals('test123_test_'+Sysutils.FloatToStr(123.456), LastResult);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTests([TCompilerTestExtended]);
|
||||
|
||||
end.
|
||||
141
components/PascalScript/dunit/CompilerTestBase.pas
Normal file
141
components/PascalScript/dunit/CompilerTestBase.pas
Normal file
@ -0,0 +1,141 @@
|
||||
|
||||
unit CompilerTestBase;
|
||||
|
||||
interface
|
||||
|
||||
uses Classes, uPSComponent, uPSCompiler, uPSRuntime, fpcunit, uPSC_std, uPSC_classes,
|
||||
uPSR_std, uPSR_classes;
|
||||
//TestFramework,
|
||||
{ Project Units }
|
||||
//ifps3,
|
||||
//ifpscomp,
|
||||
//IFPS3CompExec;
|
||||
|
||||
type
|
||||
|
||||
{ TCompilerTestBase }
|
||||
|
||||
TCompilerTestBase = class(TTestCase)
|
||||
protected
|
||||
procedure SetUp; override;
|
||||
procedure TearDown; override;
|
||||
protected
|
||||
last_script : string;
|
||||
CompExec: TIFPS3CompExec;
|
||||
//Compiler: TIFPSPascalCompiler;
|
||||
//Exec: TIFPSExec;
|
||||
procedure Compile(script: string);
|
||||
procedure CompileRun(Script: string);
|
||||
|
||||
procedure OnCompile(Sender: TPSScript); virtual;
|
||||
procedure OnExecute(Sender: TPSScript); virtual;
|
||||
procedure OnCompImport(Sender: TObject; x: TIFPSPascalCompiler); virtual;
|
||||
procedure OnExecImport(Sender: TObject; se: TIFPSExec; x: TIFPSRuntimeClassImporter); virtual;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses StrUtils, SysUtils, Math,
|
||||
Dialogs;//,
|
||||
{ Project Units }
|
||||
//ifpiir_std,
|
||||
//ifpii_std,
|
||||
//ifpiir_stdctrls,
|
||||
//ifpii_stdctrls,
|
||||
//ifpiir_forms,
|
||||
//ifpii_forms,
|
||||
//ifpii_graphics,
|
||||
//ifpii_controls,
|
||||
//ifpii_classes,
|
||||
//ifpiir_graphics,
|
||||
//ifpiir_controls,
|
||||
//ifpiir_classes;
|
||||
|
||||
function MyFormat(const Format: string;
|
||||
const Args: array of const): string;
|
||||
begin
|
||||
Result := SysUtils.Format(Format, Args);
|
||||
end;
|
||||
|
||||
|
||||
{ TCompilerTestBase }
|
||||
|
||||
procedure TCompilerTestBase.SetUp;
|
||||
begin
|
||||
inherited;
|
||||
CompExec := TIFPS3CompExec.Create(nil);
|
||||
CompExec.OnCompile := {$IFDEF FPC}@{$ENDIF}OnCompile;
|
||||
CompExec.OnExecute := {$IFDEF FPC}@{$ENDIF}OnExecute;
|
||||
CompExec.OnCompImport := {$IFDEF FPC}@{$ENDIF}OnCompImport;
|
||||
CompExec.OnExecImport := {$IFDEF FPC}@{$ENDIF}OnExecImport;
|
||||
end;
|
||||
|
||||
procedure TCompilerTestBase.TearDown;
|
||||
begin
|
||||
CompExec.Free;
|
||||
//Compiler.Free;
|
||||
//Exec.Free;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TCompilerTestBase.CompileRun(Script: string);
|
||||
var
|
||||
ok: boolean;
|
||||
begin
|
||||
last_script := Script;
|
||||
|
||||
Compile(script);
|
||||
|
||||
ok := CompExec.Execute;
|
||||
|
||||
Check(ok, 'Exec Error:' + Script + #13#10 +
|
||||
CompExec.ExecErrorToString + ' at ' +
|
||||
Inttostr(CompExec.ExecErrorProcNo) + '.' +
|
||||
Inttostr(CompExec.ExecErrorByteCodePosition));
|
||||
end;
|
||||
|
||||
procedure TCompilerTestBase.OnCompile(Sender: TPSScript);
|
||||
begin
|
||||
Sender.AddFunction(@MyFormat, 'function Format(const Format: string; const Args: array of const): string;');
|
||||
end;
|
||||
|
||||
procedure TCompilerTestBase.OnCompImport(Sender: TObject; x: TIFPSPascalCompiler);
|
||||
begin
|
||||
SIRegister_Std(x);
|
||||
SIRegister_Classes(x, true);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestBase.OnExecImport(Sender: TObject; se: TIFPSExec; x: TIFPSRuntimeClassImporter);
|
||||
begin
|
||||
RIRegister_Std(x);
|
||||
RIRegister_Classes(x, True);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestBase.OnExecute(Sender: TPSScript);
|
||||
begin
|
||||
//Sender.SetVarToInstance('SELF', Self);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestBase.Compile(script: string);
|
||||
var
|
||||
OutputMessages: string;
|
||||
ok: Boolean;
|
||||
i: Longint;
|
||||
begin
|
||||
|
||||
CompExec.Script.Clear;
|
||||
CompExec.Script.Add(Script);
|
||||
|
||||
OutputMessages := '';
|
||||
ok := CompExec.Compile;
|
||||
if (NOT ok) then
|
||||
begin
|
||||
//Get Compiler Messages now.
|
||||
for i := 0 to CompExec.CompilerMessageCount - 1 do
|
||||
OutputMessages := OutputMessages + CompExec.CompilerErrorToStr(i);
|
||||
end;
|
||||
Check(ok, 'Compiling failed:' + Script + #13#10 + OutputMessages);
|
||||
|
||||
end;
|
||||
|
||||
end.
|
||||
204
components/PascalScript/dunit/CompilerTestFunctions.pas
Normal file
204
components/PascalScript/dunit/CompilerTestFunctions.pas
Normal file
@ -0,0 +1,204 @@
|
||||
|
||||
unit CompilerTestFunctions;
|
||||
|
||||
interface
|
||||
|
||||
uses Classes,
|
||||
//TestFramework,
|
||||
//{ Project Units }
|
||||
//ifps3,
|
||||
//ifpscomp,
|
||||
//ifps3utl,
|
||||
//IFPS3CompExec,
|
||||
CompilerTestBase, uPSComponent, testregistry;
|
||||
|
||||
type
|
||||
|
||||
{ TCompilerTestFunctions }
|
||||
|
||||
TCompilerTestFunctions = class(TCompilerTestBase)
|
||||
private
|
||||
function MethodTest(const s: string): string;
|
||||
procedure AssertS(s1, s2: string);
|
||||
procedure AssertI(s1, s2: Longint);
|
||||
procedure AssertE(s1, s2: extended);
|
||||
protected
|
||||
procedure OnCompile(Sender: TPSScript); override;
|
||||
procedure OnExecute(Sender: TPSScript); override;
|
||||
published
|
||||
procedure CallProcedure;
|
||||
procedure CallMethod;
|
||||
procedure CallScriptFunctionAsMethod;
|
||||
procedure WideStringFunctions;
|
||||
procedure CheckConsts;
|
||||
end;
|
||||
|
||||
{
|
||||
TVariablesTest = class(TCompilerTest)
|
||||
private
|
||||
published
|
||||
end; }
|
||||
|
||||
implementation
|
||||
|
||||
uses StrUtils, SysUtils, Math, Dialogs;
|
||||
//,
|
||||
// { Project Units }
|
||||
// ifpiir_std,
|
||||
// ifpii_std,
|
||||
// ifpiir_stdctrls,
|
||||
// ifpii_stdctrls,
|
||||
// ifpiir_forms,
|
||||
// ifpii_forms,
|
||||
// ifpii_graphics,
|
||||
// ifpii_controls,
|
||||
// ifpii_classes,
|
||||
// ifpiir_graphics,
|
||||
// ifpiir_controls,
|
||||
// ifpiir_classes;
|
||||
|
||||
|
||||
{ TFunctionsTest }
|
||||
|
||||
var
|
||||
vResultS: string;
|
||||
vResultSw: WideString;
|
||||
aWideString: WideString;
|
||||
|
||||
procedure ResultS(const s: string);
|
||||
begin
|
||||
vResultS := s;
|
||||
end;
|
||||
|
||||
procedure ResultSw(const s: WideString);
|
||||
begin
|
||||
vResultSw := s;
|
||||
end;
|
||||
|
||||
function getWideString(): WideString;
|
||||
begin
|
||||
Result := aWideString;
|
||||
end;
|
||||
|
||||
|
||||
function MyWide2String(s: WideString): String;
|
||||
begin
|
||||
Result := s + '+Wide2String';
|
||||
end;
|
||||
|
||||
function MyString2Wide(s: String): WideString;
|
||||
begin
|
||||
Result := s + '+String2Wide';
|
||||
end;
|
||||
|
||||
function MyWide2Wide(s: WideString): WideString;
|
||||
begin
|
||||
Result := s + '+Wide2Wide';
|
||||
end;
|
||||
|
||||
procedure TCompilerTestFunctions.OnCompile(Sender: TPSScript);
|
||||
begin
|
||||
inherited;
|
||||
Sender.AddMethod(Self, @TCompilerTestFunctions.AssertS, 'procedure AssertS(s1, s2: string);');
|
||||
Sender.AddMethod(Self, @TCompilerTestFunctions.AssertI, 'procedure AssertI(s1, s2: Longint);');
|
||||
Sender.AddMethod(Self, @TCompilerTestFunctions.AssertE, 'procedure AssertE(s1, s2: Extended);');
|
||||
|
||||
|
||||
Sender.AddFunction(@ResultS, 'procedure ResultS(s: string);');
|
||||
Sender.AddFunction(@ResultSw, 'procedure ResultSw(s: WideString);');
|
||||
Sender.AddFunction(@MyString2Wide, 'function MyString2Wide(s: String): Widestring;');
|
||||
Sender.AddFunction(@MyWide2String, 'function MyWide2String(s: Widestring): string;');
|
||||
Sender.AddFunction(@MyWide2Wide, 'function MyWide2Wide(s: Widestring): Widestring;');
|
||||
Sender.AddFunction(@getWideString, 'function getWideString(): Widestring;');
|
||||
Sender.AddMethod(Self, @TCompilerTestFunctions.MethodTest, 'function MethodTest(s: string): string');
|
||||
//Sender.AddRegisteredVariable('aWideString', 'WideString');
|
||||
end;
|
||||
|
||||
procedure TCompilerTestFunctions.OnExecute(Sender: TPSScript);
|
||||
begin
|
||||
inherited;
|
||||
//Sender.SetVarToInstance('aWideString', aWideString);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestFunctions.CallProcedure;
|
||||
begin
|
||||
CompileRun('begin ResultS(''hello''); end.');
|
||||
CheckEquals('hello', vResultS, last_script);
|
||||
end;
|
||||
|
||||
|
||||
procedure TCompilerTestFunctions.WideStringFunctions;
|
||||
begin
|
||||
CompileRun('begin ResultS(MyString2Wide(''hello'')); end.');
|
||||
CheckEquals('hello+String2Wide', vResultS, last_script);
|
||||
|
||||
CompileRun('begin ResultS(MyWide2String(''hello'')); end.');
|
||||
CheckEquals('hello+Wide2String', vResultS, last_script);
|
||||
|
||||
CompileRun('begin ResultS(MyWide2Wide(''hello'')); end.');
|
||||
CheckEquals('hello+Wide2Wide', vResultS, last_script);
|
||||
|
||||
aWideString := 'Unicode=[' + WideChar($1F04) + WideChar($4004) + ']';
|
||||
CompileRun('begin ResultSw(getWideString()); end.');
|
||||
CheckEquals(aWideString, vResultSw, last_script);
|
||||
end;
|
||||
|
||||
function TCompilerTestFunctions.MethodTest(const s: string): string;
|
||||
begin
|
||||
Result := 'Test+'+s;
|
||||
end;
|
||||
|
||||
procedure TCompilerTestFunctions.CallMethod;
|
||||
begin
|
||||
CompileRun('begin ResultS(MethodTest(''hello'')); end.');
|
||||
CheckEquals('Test+hello', vResultS, last_script);
|
||||
end;
|
||||
|
||||
type
|
||||
TTestMethod = function (s: string): string of object;
|
||||
|
||||
procedure TCompilerTestFunctions.CallScriptFunctionAsMethod;
|
||||
var
|
||||
Meth: TTestMethod;
|
||||
begin
|
||||
Compile('function Test(s:string): string; begin Result := ''Test Results: ''+s;end; begin end.');
|
||||
Meth := TTestMethod(CompExec.GetProcMethod('Test'));
|
||||
Check(@Meth <> nil, 'Unable to find function');
|
||||
CheckEquals('Test Results: INDATA', Meth('INDATA'));
|
||||
end;
|
||||
|
||||
|
||||
procedure TCompilerTestFunctions.CheckConsts;
|
||||
begin
|
||||
CompileRun('const s1 = ''test''; s2 = ''data: ''+s1; s3 = s2 + ''324''; i1 = 123; i2 = i1+123; '#13#10+
|
||||
'i3 = 123 + i2; r1 = 123.0; r2 = 4123; r3 = r1 + r2; r4 = 2344.4 + r1; r5 = 23 + r1; r6 = r1 + 2344.4; '#13#10+
|
||||
'r7 = r6 + 23; begin AssertS(s1, ''test''); AssertS(s2, ''data: test''); AssertS(s3, ''data: test324'');'#13#10+
|
||||
'AssertI(i1, 123);AssertI(i2, 246);AssertI(i3, 369);AssertE(r1, 123);AssertE(r1, 123.0);AssertE(r2, 4123);'#13#10+
|
||||
'AssertE(r2, 4123.0);AssertE(r3, 4123 + 123);AssertE(r3, 4246);AssertE(r4, 2344.4 + 123);AssertE(r4, 2467.4);'#13#10+
|
||||
'AssertE(r5, 123 + 23);AssertE(r5, 123.0 + 23.0);AssertE(r5, 146.0);AssertE(r6, 2344.4 + 123);AssertE(r6, 2467.4);'#13#10+
|
||||
'AssertE(r7, 2467.4 + 23);AssertE(r7, 2490.4);end.');
|
||||
|
||||
end;
|
||||
|
||||
procedure TCompilerTestFunctions.AssertE(s1, s2: extended);
|
||||
begin
|
||||
if abs(s1 - s2) > 0.0001 then
|
||||
raise Exception.Create('AssertE: '+floattostr(s1)+' '+floattostr(s2));
|
||||
end;
|
||||
|
||||
procedure TCompilerTestFunctions.AssertI(s1, s2: Longint);
|
||||
begin
|
||||
if s1 <> s2 then
|
||||
raise Exception.Create('AssertI: '+inttostr(s1)+' '+inttostr(s2));
|
||||
end;
|
||||
|
||||
procedure TCompilerTestFunctions.AssertS(s1, s2: string);
|
||||
begin
|
||||
if s1 <> s2 then
|
||||
raise Exception.Create('AssertS: '+s1+' '+s2);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTests([ TCompilerTestFunctions ]);
|
||||
|
||||
end.
|
||||
282
components/PascalScript/dunit/CompilerTestSimple.pas
Normal file
282
components/PascalScript/dunit/CompilerTestSimple.pas
Normal file
@ -0,0 +1,282 @@
|
||||
unit CompilerTestSimple;
|
||||
|
||||
interface
|
||||
|
||||
uses Classes,
|
||||
//TestFramework,
|
||||
//{ Project Units }
|
||||
//ifps3,
|
||||
//ifpscomp,
|
||||
//IFPS3CompExec,
|
||||
CompilerTestBase, uPSCompiler, testregistry;
|
||||
|
||||
type
|
||||
TCompilerTestSimple = class(TCompilerTestBase)
|
||||
private
|
||||
protected
|
||||
LastResult: string;
|
||||
LastResultB: Boolean;
|
||||
LastResultI: Longint;
|
||||
LastResultD: Double;
|
||||
procedure OnCompImport(Sender: TObject; x: TIFPSPascalCompiler); override;
|
||||
procedure ResultD(const d: Double);
|
||||
procedure ResultS(const s: string);
|
||||
procedure ResultB(const val: Boolean);
|
||||
procedure ResultI(const val: Longint);
|
||||
published
|
||||
procedure EmptyScript;
|
||||
procedure VarDecl;
|
||||
procedure ForLoop;
|
||||
procedure WhileLoop;
|
||||
procedure CaseStatement;
|
||||
procedure RepeatLoop;
|
||||
procedure IfTest;
|
||||
procedure IfTest2;
|
||||
procedure FunctionTest;
|
||||
procedure CreateObject;
|
||||
procedure CharTest;
|
||||
procedure CharTest2;
|
||||
procedure StrConcat;
|
||||
procedure StringCharTest;
|
||||
procedure CastDoubleTest;
|
||||
procedure ConstTest;
|
||||
procedure CheckArrayProperties;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses StrUtils, SysUtils, Math, Dialogs;
|
||||
//,
|
||||
// { Project Units }
|
||||
// ifpiir_std,
|
||||
// ifpii_std,
|
||||
// ifpiir_stdctrls,
|
||||
// ifpii_stdctrls,
|
||||
// ifpiir_forms,
|
||||
// ifpii_forms,
|
||||
// ifpii_graphics,
|
||||
// ifpii_controls,
|
||||
// ifpii_classes,
|
||||
// ifpiir_graphics,
|
||||
// ifpiir_controls,
|
||||
// ifpiir_classes;
|
||||
|
||||
{ TCompilerTestSimple }
|
||||
|
||||
|
||||
procedure TCompilerTestSimple.OnCompImport(Sender: TObject;
|
||||
x: TIFPSPascalCompiler);
|
||||
begin
|
||||
inherited;
|
||||
CompExec.AddMethod(Self, @TCompilerTestSimple.ResultS, 'procedure ResultS(const s: string);');
|
||||
CompExec.AddMethod(Self, @TCompilerTestSimple.ResultB, 'procedure ResultB(const b: Boolean);');
|
||||
CompExec.AddMethod(Self, @TCompilerTestSimple.ResultI, 'procedure ResultI(const I: Longint);');
|
||||
CompExec.AddMethod(Self, @TCompilerTestSimple.ResultD, 'procedure ResultD(const D: Double);');
|
||||
end;
|
||||
|
||||
|
||||
procedure TCompilerTestSimple.ResultS(const s: string);
|
||||
begin
|
||||
LastResult := s;
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
CaseScript =
|
||||
'Program Test; begin case %d of 0: ResultS(''0'');1: ResultS(''1'');2: ResultS(''2'');'+
|
||||
'3: ResultS(''3'');else Results(''e''); end;end.';
|
||||
|
||||
procedure TCompilerTestSimple.CaseStatement;
|
||||
begin
|
||||
CompileRun(Format(CaseScript, [-10]));
|
||||
CheckEquals('e', LastResult, last_script);
|
||||
CompileRun(Format(CaseScript, [0]));
|
||||
CheckEquals('0', LastResult, last_script);
|
||||
CompileRun(Format(CaseScript, [2]));
|
||||
CheckEquals('2', LastResult, last_script);
|
||||
CompileRun(Format(CaseScript, [3]));
|
||||
CheckEquals('3', LastResult, last_script);
|
||||
CompileRun(Format(CaseScript, [4]));
|
||||
CheckEquals('e', LastResult, last_script);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.EmptyScript;
|
||||
begin
|
||||
CompileRun('Program Test; begin end.');
|
||||
CompileRun('begin end.');
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.ForLoop;
|
||||
begin
|
||||
CompileRun('var i, j: Integer; begin for i := 0 to 100 do j := j + i; ResultI(j); end.');
|
||||
CheckEquals(5050, LastResultI, last_script);
|
||||
CompileRun('var i, j: Integer; begin j := 1; for i := 1 to 10 do j := j * i; ResultI(j); end.');
|
||||
CheckEquals(3628800, LastResultI, last_script);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.FunctionTest;
|
||||
begin
|
||||
CompileRun('function test: string; begin Result := ''Func_Res''; end; begin ResultS(test+''+test''); end.');
|
||||
CheckEquals('Func_Res+test', LastResult, last_script);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.IfTest;
|
||||
begin
|
||||
CompileRun('begin if true then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(true, LastResultB, last_script);
|
||||
CompileRun('begin if false then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(False, LastResultB, last_script);
|
||||
|
||||
CompileRun('begin if not true then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(False, LastResultB, last_script);
|
||||
CompileRun('begin if not false then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(true, LastResultB, last_script);
|
||||
|
||||
CompileRun('begin if not (true) then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(False, LastResultB, last_script);
|
||||
CompileRun('begin if not (false) then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(true, LastResultB, last_script);
|
||||
|
||||
CompileRun('begin if (not true) then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(False, LastResultB, last_script);
|
||||
CompileRun('begin if (not false) then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(true, LastResultB, last_script);
|
||||
|
||||
CompileRun('begin if true and true then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(true, LastResultB, last_script);
|
||||
CompileRun('begin if true and false then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(False, LastResultB, last_script);
|
||||
CompileRun('begin if false and true then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(False, LastResultB, last_script);
|
||||
CompileRun('begin if false and false then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(False, LastResultB, last_script);
|
||||
|
||||
CompileRun('begin if true or true then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(true, LastResultB, last_script);
|
||||
CompileRun('begin if true or false then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(true, LastResultB, last_script);
|
||||
CompileRun('begin if false or true then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(true, LastResultB, last_script);
|
||||
CompileRun('begin if false or false then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(False, LastResultB, last_script);
|
||||
|
||||
CompileRun('begin if true xor true then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(False, LastResultB, last_script);
|
||||
CompileRun('begin if true xor false then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(true, LastResultB, last_script);
|
||||
CompileRun('begin if false xor true then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(true, LastResultB, last_script);
|
||||
CompileRun('begin if false xor false then ResultB(True) else ResultB(False); end.');
|
||||
CheckEquals(False, LastResultB, last_script);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
procedure TCompilerTestSimple.RepeatLoop;
|
||||
begin
|
||||
CompileRun('var i: Integer; begin Repeat i := i + 8; until i mod 7 = 6; ResultI(I); end.');
|
||||
CheckEquals(48, LastResultI, last_script);
|
||||
end;
|
||||
|
||||
|
||||
procedure TCompilerTestSimple.WhileLoop;
|
||||
begin
|
||||
CompileRun('var i, j: Integer; begin while i < 10 do begin j := j + 1; i := j; end; ResultI(i+j); end.');
|
||||
CheckEquals(20, LastResultI, last_script);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.CharTest;
|
||||
begin
|
||||
CompileRun('var s: string; begin s := ''''+chr(32) + chr(45) + chr(45); ResultS(s); end.');
|
||||
CheckEquals(#32#45#45, LastResult, last_script);
|
||||
CompileRun('var s: string; begin s := chr(32) + chr(45) + chr(45); ResultS(s); end.');
|
||||
CheckEquals(#32#45#45, LastResult, last_script);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.StringCharTest;
|
||||
begin
|
||||
CompileRun('var s: string; begin s:=''123456789''; s[1]:=s[2]; ResultS(s); end.');
|
||||
CheckEquals('223456789', LastResult, last_script);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.CastDoubleTest;
|
||||
begin
|
||||
CompileRun('function Test(i1, i2: Integer): Double; begin Result := Double(i1) / i2; end; var Res: Double; begin res := Test(10, 2); ResultD(Res); end.');
|
||||
CheckEquals(10/2, LastResultD, 0.000001, last_script);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.ResultB(const val: Boolean);
|
||||
begin
|
||||
LastResultB := Val;
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.ResultI(const val: Integer);
|
||||
begin
|
||||
LastResultI := Val;
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.ResultD(const d: Double);
|
||||
begin
|
||||
LastResultD := D;
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.ConstTest;
|
||||
begin
|
||||
CompileRun('const a = 10; b = a * 3; begin ResultI(b);end.');
|
||||
CheckEquals(30, LastResultI, last_script);
|
||||
CompileRun('const a = (1+4)*6+1; begin ResultI(a);end.');
|
||||
CheckEquals(31, LastResultI, last_script);
|
||||
CompileRun('const a = 2 * -(3 + 4) + (5 + 6) mod 5; begin ResultI(a);end.');
|
||||
CheckEquals(-13, LastResultI, last_script);
|
||||
CompileRun('const b = ''a''+''b''+''c'';a = b = ''a''+''b''+''c'';begin ResultB(a);end.');
|
||||
CheckEquals(true, LastResultB, last_script);
|
||||
end;
|
||||
|
||||
const
|
||||
IfTest2Script = 'var backclicked: Boolean; curpage: integer; wpselectdir: integer;'+
|
||||
'procedure Beep(i: Longint); begin if i = 2 then RaiseException(erCustomError, ''currpage <> '+
|
||||
'wpSelectDir''); if i = 3 then RaiseException(erCustomError, ''not False and False'');end;'+
|
||||
'Begin backclicked := false; curpage := 0; wpSelectDir := 5; if not BackClicked then Beep(1);'+
|
||||
'if CurPage = wpSelectDir then Beep(2); if not BackClicked and (CurPage = wpSelectDir) then Beep(3);End.';
|
||||
|
||||
|
||||
procedure TCompilerTestSimple.IfTest2;
|
||||
begin
|
||||
CompileRun(IfTest2Script);
|
||||
CompileRun('Program IFSTest; type TShiftStates = (ssCtrl, ssShift); TShiftState = set of TShiftStates; var shift: TShiftState; Begin if shift = [ssCtrl, ssShift] then End.');
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.checkArrayProperties;
|
||||
begin
|
||||
CompileRun('var r: TStringList; begin r := TStringList.Create; r.Values[''test''] := ''data''; ResultS(r.text); r.Free;end.');
|
||||
CheckEquals('test=data'#13#10, LastResult);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.VarDecl;
|
||||
begin
|
||||
CompileRun('Program test; var i: Longint; begin end.');
|
||||
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.StrConcat;
|
||||
begin
|
||||
CompileRun('var s: string; begin s := ''test''; s := s + ''TESTED''; ResultS(s); End.');
|
||||
CheckEquals('testTESTED', LastResult);
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.CreateObject;
|
||||
begin
|
||||
CompileRun('var r: TObject; begin r := TObject.Create; r.Free; end.');
|
||||
end;
|
||||
|
||||
procedure TCompilerTestSimple.CharTest2;
|
||||
begin
|
||||
CompileRun('var s:string; i:integer; begin i := ord(''a''); s:=chr(i); '+
|
||||
'i := ord(''a'');s:=chr(i + 1); end.');
|
||||
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTests([TCompilerTestSimple]);
|
||||
|
||||
end.
|
||||
101
components/PascalScript/dunit/ifps3.lpi
Normal file
101
components/PascalScript/dunit/ifps3.lpi
Normal file
@ -0,0 +1,101 @@
|
||||
<?xml version="1.0"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="ifps3"/>
|
||||
<ResourceType Value="res"/>
|
||||
<UseXPManifest Value="True"/>
|
||||
<Icon Value="0"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
|
||||
<ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="4">
|
||||
<Item1>
|
||||
<PackageName Value="pascalscript"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="FPCUnitTestRunner"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item3>
|
||||
<Item4>
|
||||
<PackageName Value="FCL"/>
|
||||
</Item4>
|
||||
</RequiredPackages>
|
||||
<Units Count="5">
|
||||
<Unit0>
|
||||
<Filename Value="ifps3.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="ifps3"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="CompilerTestBase.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="CompilerTestBase"/>
|
||||
</Unit1>
|
||||
<Unit2>
|
||||
<Filename Value="CompilerTestFunctions.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="CompilerTestFunctions"/>
|
||||
</Unit2>
|
||||
<Unit3>
|
||||
<Filename Value="CompilerTestSimple.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="CompilerTestSimple"/>
|
||||
</Unit3>
|
||||
<Unit4>
|
||||
<Filename Value="CompileTestExtended.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="CompileTestExtended"/>
|
||||
</Unit4>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
</SearchPaths>
|
||||
<Other>
|
||||
<CompilerMessages>
|
||||
<MsgFileName Value=""/>
|
||||
</CompilerMessages>
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
16
components/PascalScript/dunit/ifps3.lpr
Normal file
16
components/PascalScript/dunit/ifps3.lpr
Normal file
@ -0,0 +1,16 @@
|
||||
program ifps3;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
Interfaces, Forms, GuiTestRunner, CompilerTestBase, CompilerTestFunctions,
|
||||
CompilerTestSimple, CompileTestExtended, pascalscript;
|
||||
|
||||
{$R *.res}
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TGuiTestRunner, TestRunner);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user