1 {
2 Test all with:
3 ./runtests --format=plain --suite=TTestPascalParser
4
5 Test specific with:
6 ./runtests --format=plain --suite=TestRecord_ClassOperators
7 }
8 unit TestPascalParser;
9
10 {$mode objfpc}{$H+}
11
12 interface
13
14 uses
15 Classes, SysUtils, math, CodeToolManager, CodeCache, CodeAtom,
16 LazLogger, fpcunit, testregistry, TestGlobals;
17
18 type
19
20 { TCustomTestPascalParser }
21
22 TCustomTestPascalParser = class(TTestCase)
23 private
24 FCode: TCodeBuffer;
25 protected
26 procedure SetUp; override;
27 procedure TearDown; override;
28 procedure DoParseModule(aCode: TCodeBuffer; out Tool: TCodeTool);
29 public
30 procedure Add(const s: string);
31 procedure Add(Args: array of const);
32 procedure StartUnit;
StartProgramnull33 function StartProgram: boolean; virtual;
34 procedure ParseModule;
35 procedure CheckParseError(const CursorPos: TCodeXYPosition; Msg: string);
36 procedure WriteSource(CleanPos: integer; Tool: TCodeTool);
37 procedure WriteSource(const CursorPos: TCodeXYPosition);
38 property Code: TCodeBuffer read FCode;
39 end;
40
41 { TTestPascalParser }
42
43 TTestPascalParser = class(TCustomTestPascalParser)
44 published
45 procedure TestAtomRing;
46 procedure TestRecord_ClassOperators;
47 procedure TestRecord_Nonkeywords;
48 procedure TestDeprecated;
49 procedure TestMissingGenericKeywordObjFPCFail;
50 procedure TestParseGenericsDelphi;
51 procedure TestParseExternalConcat;
52 procedure TestParseExternalConst;
53 procedure TestParseModeTP;
54 end;
55
56 implementation
57
58 { TCustomTestPascalParser }
59
60 procedure TCustomTestPascalParser.SetUp;
61 begin
62 inherited SetUp;
63 FCode:=CodeToolBoss.CreateFile('test1.pas');
64 end;
65
66 procedure TCustomTestPascalParser.TearDown;
67 begin
68 inherited TearDown;
69 end;
70
71 procedure TCustomTestPascalParser.DoParseModule(aCode: TCodeBuffer; out
72 Tool: TCodeTool);
73 var
74 i: Integer;
75 Line: String;
76 begin
77 if not CodeToolBoss.Explore(aCode,Tool,true) then begin
78 debugln(aCode.Filename+'------------------------------------------');
79 for i:=1 to aCode.LineCount do begin
80 Line:=aCode.GetLine(i-1,false);
81 if i=CodeToolBoss.ErrorLine then
82 System.Insert('|',Line,CodeToolBoss.ErrorColumn);
83 debugln(Format('%:4d: ',[i]),Line);
84 end;
85 debugln('Error: '+CodeToolBoss.ErrorDbgMsg);
86 Fail('PascalParser failed: '+CodeToolBoss.ErrorMessage);
87 end;
88 end;
89
90 procedure TCustomTestPascalParser.Add(const s: string);
91 begin
92 FCode.Source:=FCode.Source+s+LineEnding;
93 end;
94
95 procedure TCustomTestPascalParser.Add(Args: array of const);
96 begin
97 FCode.Source:=FCode.Source+LinesToStr(Args);
98 end;
99
100 procedure TCustomTestPascalParser.StartUnit;
101 begin
102 Add('unit test1;');
103 Add('');
104 Add('{$mode objfpc}{$H+}');
105 Add('');
106 Add('interface');
107 Add('');
108 end;
109
StartProgramnull110 function TCustomTestPascalParser.StartProgram: boolean;
111 begin
112 Result:=true;
113 Add('program test1;');
114 Add('');
115 Add('{$mode objfpc}{$H+}');
116 Add('');
117 end;
118
119 procedure TCustomTestPascalParser.ParseModule;
120 var
121 Tool: TCodeTool;
122 begin
123 Add('end.');
124 DoParseModule(Code,Tool);
125 end;
126
127 procedure TCustomTestPascalParser.CheckParseError(
128 const CursorPos: TCodeXYPosition; Msg: string);
129 var
130 Tool: TCodeTool;
131 begin
132 if CodeToolBoss.Explore(Code,Tool,true) then begin
133 WriteSource(CursorPos);
134 Fail('missing parser error "'+Msg+'"');
135 end;
136 if Tool=nil then begin
137 WriteSource(CursorPos);
138 Fail('missing Tool, Msg="'+Msg+'"');
139 end;
140 if CursorPos.Code<>CodeToolBoss.ErrorCode then begin
141 WriteSource(CursorPos);
142 Fail('expected parser error "'+Msg+'" in "'+CursorPos.Code.Filename+'", not in "'+CodeToolBoss.ErrorCode.Filename+'"');
143 end;
144 if (CursorPos.Y<>CodeToolBoss.ErrorLine) or (CursorPos.X<>CodeToolBoss.ErrorColumn) then begin
145 WriteSource(CursorPos);
146 Fail('expected parser error "'+Msg+'" at line='+IntToStr(CursorPos.Y)+' col='+IntToStr(CursorPos.X)+', but got line='+IntToStr(CodeToolBoss.ErrorLine)+' col='+IntToStr(CodeToolBoss.ErrorColumn));
147 end;
148 if (Msg<>CodeToolBoss.ErrorMessage) then begin
149 WriteSource(CursorPos);
150 Fail('expected parser error "'+Msg+'" instead of "'+CodeToolBoss.ErrorMessage+'"');
151 end;
152 end;
153
154 procedure TCustomTestPascalParser.WriteSource(CleanPos: integer; Tool: TCodeTool
155 );
156 var
157 Caret: TCodeXYPosition;
158 begin
159 if Tool=nil then
160 Fail('TCustomTestPascalParser.WriteSource: missing Tool');
161 if not Tool.CleanPosToCaret(CleanPos,Caret) then
162 Fail('TCustomTestPascalParser.WriteSource: invalid cleanpos '+IntToStr(CleanPos)+' Tool='+Tool.MainFilename);
163 WriteSource(Caret);
164 end;
165
166 procedure TCustomTestPascalParser.WriteSource(const CursorPos: TCodeXYPosition);
167 var
168 CurCode: TCodeBuffer;
169 i: Integer;
170 Line: String;
171 begin
172 CurCode:=CursorPos.Code;
173 if CurCode=nil then
174 Fail('TCustomTestPascalParser.WriteSource CurCode=nil');
175 for i:=1 to CurCode.LineCount do begin
176 Line:=CurCode.GetLine(i-1,false);
177 if (i=CursorPos.Y) then begin
178 write('*');
179 Line:=LeftStr(Line,CursorPos.X-1)+'|'+copy(Line,CursorPos.X,length(Line));
180 end;
181 writeln(Format('%:4d: ',[i]),Line);
182 end;
183 end;
184
185 { TTestPascalParser }
186
187 procedure TTestPascalParser.TestAtomRing;
188
189 procedure CheckAtom(Msg: String; const Expected, Actual: TAtomPosition);
190 begin
191 AssertEquals(Msg+' StartPos',Expected.StartPos,Actual.StartPos);
192 AssertEquals(Msg+' EndPos',Expected.EndPos,Actual.EndPos);
193 if Expected.Flag<>Actual.Flag then
194 Fail(Msg+' Flag Expected='+CommonAtomFlagNames[Expected.Flag]+' but found '+CommonAtomFlagNames[Actual.Flag]);
195 end;
196
197 procedure CheckIndexOf(Msg: string; R: TAtomRing);
198 var
199 i, Actual: Integer;
200 P: TAtomPosition;
201 begin
202 for i:=1-R.PriorCount to R.NextCount do begin
203 P:=R.GetAtomAt(i);
204 if not R.IndexOf(P.StartPos,Actual) then
205 Fail(Msg+' CheckIndexOf i='+IntToStr(i)+' IndexOf failed');
206 AssertEquals(Msg+' CheckIndexOf',i,Actual);
207 end;
208 end;
209
210 var
211 R: TAtomRing;
212 P, P1, P2: TAtomPosition;
213 i: Integer;
214 begin
215 R:=TAtomRing.Create;
216 try
217 R.Size:=4;
218 AssertEquals('1-empty count',0,R.PriorCount);
219 AssertEquals('1-empty nextcount',0,R.NextCount);
220
221 P1:=AtomPosition(1,2,cafWord);
222 R.Add(P1);
223 AssertEquals('2-first atom count',1,R.PriorCount);
224 AssertEquals('2-first atom nextcount',0,R.NextCount);
225 P:=R.GetAtomAt(0);
226 CheckAtom('2-first atom',P1,P);
227
228 CheckIndexOf('2-first atom',R);
229
230 R.UndoLastAdd;
231 //R.WriteDebugReport;
232 AssertEquals('3-empty after undo count',0,R.PriorCount);
233 AssertEquals('3-empty after undo nextcount',0,R.NextCount);
234
235 P1:=AtomPosition(1,2,cafWord);
236 R.Add(P1);
237 //R.WriteDebugReport;
238 AssertEquals('4-first atom count',1,R.PriorCount);
239 AssertEquals('4-first atom nextcount',0,R.NextCount);
240 P:=R.GetAtomAt(0);
241 CheckAtom('4-first atom',P1,P);
242 CheckIndexOf('4-first atom',R);
243
244 P2:=AtomPosition(3,4,cafWord);
245 R.Add(P2);
246 //R.WriteDebugReport;
247
248 AssertEquals('5-second atom count',2,R.PriorCount);
249 AssertEquals('5-second atom nextcount',0,R.NextCount);
250 P:=R.GetAtomAt(0);
251 CheckAtom('5-second atom 0',P2,P);
252 P:=R.GetAtomAt(-1);
253 CheckAtom('5-second atom -1',P1,P);
254 CheckIndexOf('5-second atom',R);
255
256 R.UndoLastAdd;
257 //R.WriteDebugReport;
258 AssertEquals('6-undo after add two: count',1,R.PriorCount);
259 AssertEquals('6-undo after add two: nextcount',1,R.NextCount);
260 P:=R.GetAtomAt(0);
261 CheckAtom('6-undo after add two: atom 0',P1,P);
262 P:=R.GetAtomAt(1);
263 CheckAtom('6-undo after add two: atom +1',P2,P);
264 CheckIndexOf('6-undo after add two',R);
265
266 P2:=AtomPosition(5,6,cafWord);
267 R.Add(P2);
268 //R.WriteDebugReport;
269
270 AssertEquals('7-second atom count',2,R.PriorCount);
271 AssertEquals('7-second atom nextcount',0,R.NextCount);
272 P:=R.GetAtomAt(0);
273 CheckAtom('7-second atom 0',P2,P);
274 P:=R.GetAtomAt(-1);
275 CheckAtom('7-second atom -1',P1,P);
276 CheckIndexOf('7-second atom',R);
277
278 R.Clear;
279 //R.WriteDebugReport;
280 for i:=1 to 5 do begin
281 // add first
282 P1:=AtomPosition(i*4,i*4+1,cafWord);
283 R.Add(P1);
284 //R.WriteDebugReport;
285 AssertEquals('8-Added first: '+IntToStr(i)+' count',Min(i,R.Size),R.PriorCount);
286 AssertEquals('8-Added first: '+IntToStr(i)+' nextcount',0,R.NextCount);
287 P:=R.GetAtomAt(0);
288 CheckAtom('8-Added first: atom 0',P1,P);
289 CheckIndexOf('8-Added first',R);
290
291 // add two
292 P2:=AtomPosition(i*4+2,i*4+3,cafWord);
293 R.Add(P2);
294 //R.WriteDebugReport;
295 AssertEquals('9-Added second: '+IntToStr(i)+' count',Min(i+1,R.Size),R.PriorCount);
296 AssertEquals('9-Added second: '+IntToStr(i)+' nextcount',0,R.NextCount);
297 P:=R.GetAtomAt(0);
298 CheckAtom('9-Added second: '+IntToStr(i)+' atom 0',P2,P);
299 P:=R.GetAtomAt(-1);
300 CheckAtom('9-Added second: '+IntToStr(i)+' atom -1',P1,P);
301 CheckIndexOf('9-Added second',R);
302
303 // undo one
304 R.UndoLastAdd;
305 //R.WriteDebugReport;
306 AssertEquals('10-Undo: '+IntToStr(i)+' count',Min(i,R.Size-1),R.PriorCount);
307 AssertEquals('10-Undo: '+IntToStr(i)+' nextcount',1,R.NextCount);
308 P:=R.GetAtomAt(0);
309 CheckAtom('10-Undo: '+IntToStr(i)+' atom 0',P1,P);
310 P:=R.GetAtomAt(1);
311 CheckAtom('10-Undo: '+IntToStr(i)+' atom +1',P2,P);
312 CheckIndexOf('10-Undo',R);
313 end;
314
315 FreeAndNil(R);
316 finally
317 if R<>nil then begin
318 R.WriteDebugReport;
319 R.Free;
320 end;
321 end;
322 end;
323
324 procedure TTestPascalParser.TestRecord_ClassOperators;
325 begin
326 StartProgram;
327 Add([
328 '{$modeswitch advancedrecords}',
329 'type',
330 ' TFlag = (flag1);',
331 '{$Define FPC_HAS_MANAGEMENT_OPERATORS}',
332 ' TMyRecord = record',
333 ' class operator Implicit(t: TMyRecord): TMyRecord;',
334 ' class operator Explicit(t: TMyRecord): TMyRecord;',
335 ' class operator Negative(t: TMyRecord): TMyRecord;',
336 ' class operator Positive(t: TMyRecord): TMyRecord;',
337 ' class operator Inc(t: TMyRecord): TMyRecord;',
338 ' class operator Dec(t: TMyRecord): TMyRecord;',
339 ' class operator LogicalNot(t: TMyRecord): TMyRecord;',
340 ' class operator Trunc(t: TMyRecord): TMyRecord;',
341 ' class operator Round(t: TMyRecord): TMyRecord;',
342 ' class operator In(f: TFlag; t: TMyRecord): boolean;',
343 ' class operator Equal(t1, t2: TMyRecord): boolean;',
344 ' class operator NotEqual(t1, t2: TMyRecord): boolean;',
345 ' class operator GreaterThan(t1, t2: TMyRecord): boolean;',
346 ' class operator GreaterThanOrEqual(t1, t2: TMyRecord): boolean;',
347 ' class operator LessThan(t1, t2: TMyRecord): boolean;',
348 ' class operator LessThanOrEqual(t1, t2: TMyRecord): boolean;',
349 ' class operator Add(t1, t2: TMyRecord): TMyRecord;',
350 ' class operator Subtract(t1, t2: TMyRecord): TMyRecord;',
351 ' class operator Multiply(t1, t2: TMyRecord): TMyRecord;',
352 ' class operator Divide(t1, t2: TMyRecord): TMyRecord;',
353 ' class operator IntDivide(t1, t2: TMyRecord): TMyRecord;',
354 ' class operator Modulus(t1, t2: TMyRecord): TMyRecord;',
355 ' class operator LeftShift(t1, t2: TMyRecord): TMyRecord;',
356 ' class operator RightShift(t1, t2: TMyRecord): TMyRecord;',
357 ' class operator LogicalAnd(b: boolean; t: TMyRecord): TMyRecord;',
358 ' class operator LogicalOr(b: boolean; t: TMyRecord): TMyRecord;',
359 ' class operator LogicalXor(b: boolean; t: TMyRecord): TMyRecord;',
360 ' class operator BitwiseAnd(t1, t2: TMyRecord): TMyRecord;',
361 ' class operator BitwiseOr(t1, t2: TMyRecord): TMyRecord;',
362 ' class operator BitwiseXor(t1, t2: TMyRecord): TMyRecord;',
363 ' // only IFDEF FPC_HAS_MANAGEMENT_OPERATORS',
364 ' class operator Initialize(var t: TMyRecord);',
365 ' class operator Finalize(var t: TMyRecord);',
366 ' class operator Copy(var t: TMyRecord);',
367 ' class operator AddRef(constref t1: TMyRecord ; var t2: TMyRecord);',
368 ' end;',
369 '',
370 'class operator TMyRecord.Implicit(t: TMyRecord): TMyRecord;',
371 'begin end;',
372 '',
373 '// only IFDEF FPC_HAS_MANAGEMENT_OPERATORS',
374 'class operator TMyRecord.Initialize(var t: TMyRecord);',
375 'begin end;',
376 '',
377 'begin'
378 ]);
379 ParseModule;
380 end;
381
382 procedure TTestPascalParser.TestRecord_Nonkeywords;
383 begin
384 StartProgram;
385 Add([
386 'type',
387 ' t = record',
388 ' public: word;',
389 ' private: word;',
390 ' protected: word;',
391 ' published: word;',
392 ' end;',
393 'begin']);
394 ParseModule;
395 end;
396
397 procedure TTestPascalParser.TestDeprecated;
398 begin
399 StartProgram;
400 Add([
401 'type',
402 ' t = string deprecated ''t'';',
403 ' TBird = class',
404 ' FA: longint deprecated;',
405 ' Deprecated: longint;',
406 ' procedure SetA; deprecated;',
407 ' property A: longint read FA; deprecated;',
408 ' Platform: longint;',
409 ' end deprecated ''tbird'';',
410 'var',
411 ' c: char deprecated;',
412 ' b: boolean deprecated ''b'';',
413 ' deprecated: boolean;',
414 'procedure DoIt; deprecated;',
415 'begin end;',
416 'begin']);
417 ParseModule;
418 end;
419
420 procedure TTestPascalParser.TestMissingGenericKeywordObjFPCFail;
421 begin
422 Add([
423 'program test1;',
424 '{$mode objfpc}',
425 'type',
426 ' TList<T> = class end;',
427 'begin']);
428 CheckParseError(CodeXYPosition(8,4,Code),'expected =, but < found');
429 end;
430
431 procedure TTestPascalParser.TestParseGenericsDelphi;
432 begin
433 Add([
434 'program test1;',
435 '{$mode delphi}',
436 'type',
437 ' TRec = record',
438 ' procedure Proc<T>;', // generic proc inside normal record
439 ' end;',
440 ' TBird<B> = class(TAnimal<B>)',
441 ' procedure DoIt;', // normal proc inside generic class
442 ' procedure DoSome<T>;', // generic proc inside generic class
443 ' generic class procedure DoGen<P>(i: P);',
444 ' end;',
445 'procedure TRec.Proc<T>;', // generic proc inside normal record
446 'begin',
447 'end;',
448 'procedure TBird<B>.DoIt;', // normal proc inside generic class
449 'begin',
450 'end;',
451 'procedure TBird<B>.DoSome<T>;', // generic proc inside generic class
452 'begin',
453 'end;',
454 'generic class procedure TBird<B>.DoGen<P>(i: P);',
455 'begin',
456 'end;',
457 'begin']);
458 ParseModule;
459 end;
460
461 procedure TTestPascalParser.TestParseExternalConcat;
462 begin
463 Add([
464 'program test1;',
465 '{$mode objfpc}',
466 'procedure foo; cdecl; external name concat(''foo'', ''bar'');',
467 'begin']);
468 ParseModule;
469 end;
470
471 procedure TTestPascalParser.TestParseExternalConst;
472 begin
473 Add([
474 'program test1;',
475 'const NaN: double; external;',
476 'const nan: double; external name ''NaN'';',
477 '{$modeswitch externalclass}',
478 'type',
479 ' TExtA = class external name ''ExtA''',
480 ' const id;',
481 ' end;',
482 'begin']);
483 ParseModule;
484 end;
485
486 procedure TTestPascalParser.TestParseModeTP;
487 begin
488 Add([
489 'program test1;',
490 '{$mode tp}',
491 '{ {}',
492 'begin']);
493 ParseModule;
494 end;
495
496 initialization
497 RegisterTest(TTestPascalParser);
498
499 end.
500
501