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
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
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
// Does not work in fpc (same code compiled fails too)
// 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.
|
