1 unit tconstparser;
2 
3 {$mode objfpc}{$H+}
4 
5 interface
6 
7 uses
8   Classes, SysUtils, fpcunit, pastree, pscanner, tcbaseparser, testregistry, pparser;
9 
10 Type
11     { TTestConstParser }
12 
13   TTestConstParser = Class(TTestParser)
14   private
15     FConst: TPasConst;
16     FExpr: TPasExpr;
17     FHint : string;
18     FTyped: String;
19     procedure DoParseConstUnTypedRange;
20   Protected
ParseConstnull21     Function ParseConst(ASource : String) : TPasConst;
22     Procedure CheckExprNameKindClass(AKind : TPasExprKind; AClass : TClass);
23     Property TheConst : TPasConst Read FConst;
24     Property TheExpr : TPasExpr Read FExpr;
25     Property Hint : string Read FHint Write FHint;
26     Property Typed : String Read FTyped Write FTyped;
27     procedure SetUp; override;
28   Public
29     Procedure DoTestSimpleIntConst;
30     Procedure DoTestSimpleFloatConst;
31     Procedure DoTestSimpleStringConst;
32     Procedure DoTestSimpleNilConst;
33     Procedure DoTestSimpleBoolConst;
34     Procedure DoTestSimpleIdentifierConst;
35     Procedure DoTestSimpleSetConst;
36     Procedure DoTestSimpleExprConst;
37   Published
38     Procedure TestSimpleIntConst;
39     Procedure TestSimpleFloatConst;
40     Procedure TestSimpleStringConst;
41     Procedure TestSimpleNilConst;
42     Procedure TestSimpleBoolConst;
43     Procedure TestSimpleIdentifierConst;
44     Procedure TestSimpleSetConst;
45     Procedure TestSimpleExprConst;
46     Procedure TestSimpleIntConstDeprecatedMsg;
47     Procedure TestSimpleIntConstDeprecated;
48     Procedure TestSimpleFloatConstDeprecated;
49     Procedure TestSimpleStringConstDeprecated;
50     Procedure TestSimpleNilConstDeprecated;
51     Procedure TestSimpleBoolConstDeprecated;
52     Procedure TestSimpleIdentifierConstDeprecated;
53     Procedure TestSimpleSetConstDeprecated;
54     Procedure TestSimpleExprConstDeprecated;
55     Procedure TestSimpleIntConstPlatform;
56     Procedure TestSimpleFloatConstPlatform;
57     Procedure TestSimpleStringConstPlatform;
58     Procedure TestSimpleNilConstPlatform;
59     Procedure TestSimpleBoolConstPlatform;
60     Procedure TestSimpleIdentifierConstPlatform;
61     Procedure TestSimpleSetConstPlatform;
62     Procedure TestSimpleExprConstPlatform;
63     Procedure TestSimpleIntConstExperimental;
64     Procedure TestSimpleFloatConstExperimental;
65     Procedure TestSimpleStringConstExperimental;
66     Procedure TestSimpleNilConstExperimental;
67     Procedure TestSimpleBoolConstExperimental;
68     Procedure TestSimpleIdentifierConstExperimental;
69     Procedure TestSimpleSetConstExperimental;
70     Procedure TestSimpleExprConstExperimental;
71     Procedure TestTypedIntConst;
72     Procedure TestTypedFloatConst;
73     Procedure TestTypedStringConst;
74     Procedure TestTypedNilConst;
75     Procedure TestTypedBoolConst;
76     Procedure TestTypedIdentifierConst;
77     Procedure TestTypedSetConst;
78     Procedure TestTypedExprConst;
79     Procedure TestRecordConst;
80     Procedure TestArrayConst;
81     Procedure TestRangeConst;
82     Procedure TestRangeConstUnTyped;
83     Procedure TestArrayOfRangeConst;
84   end;
85 
86   { TTestResourcestringParser }
87 
88   TTestResourcestringParser = Class(TTestParser)
89   private
90     FExpr: TPasExpr;
91     FHint : string;
92     FTheStr: TPasResString;
93   Protected
ParseResourcestringnull94     Function ParseResourcestring(ASource : String) : TPasResString;
95     Procedure CheckExprNameKindClass(AKind : TPasExprKind; AClass : TClass);
96     Property Hint : string Read FHint Write FHint;
97     Property TheStr : TPasResString Read FTheStr;
98     Property TheExpr : TPasExpr Read FExpr;
99   Public
100     Procedure DoTestSimple;
101     Procedure DoTestSum;
102     Procedure DoTestSum2;
103   Published
104     Procedure TestSimple;
105     Procedure TestSimpleDeprecated;
106     Procedure TestSimplePlatform;
107     Procedure TestSum1;
108     Procedure TestSum1Deprecated;
109     Procedure TestSum1Platform;
110     Procedure TestSum2;
111     Procedure TestSum2Deprecated;
112     Procedure TestSum2Platform;
113   end;
114 
115 
116 implementation
117 { TTestConstParser }
118 
ParseConstnull119 function TTestConstParser.ParseConst(ASource: String): TPasConst;
120 
121 Var
122   D : String;
123 begin
124   Add('Const');
125   D:=' A ';
126   If (Typed<>'') then
127     D:=D+' : '+Typed+' ';
128   D:=D+' = '+ASource;
129   If Hint<>'' then
130     D:=D+' '+Hint;
131   Add('  '+D+';');
132   ParseDeclarations;
133   AssertEquals('One constant definition',1,Declarations.Consts.Count);
134   AssertEquals('First declaration is constant definition.',TPasConst,TObject(Declarations.Consts[0]).ClassType);
135   Result:=TPasConst(Declarations.Consts[0]);
136   AssertNotNull(Result.Expr);
137   FExpr:=Result.Expr;
138   FConst:=Result;
139   Definition:=Result;
140 end;
141 
142 
143 procedure TTestConstParser.CheckExprNameKindClass(
144   AKind: TPasExprKind; AClass : TClass);
145 begin
146   AssertEquals('Correct name','A',TheConst.Name);
147   AssertExpression('Const', TheExpr,aKind,AClass);
148 end;
149 
150 procedure TTestConstParser.SetUp;
151 begin
152   inherited SetUp;
153   Hint:='';
154 end;
155 
156 procedure TTestConstParser.DoTestSimpleIntConst;
157 
158 begin
159   ParseConst('1');
160   AssertExpression('Integer Const',TheExpr,pekNumber,'1');
161 end;
162 
163 procedure TTestConstParser.DoTestSimpleFloatConst;
164 begin
165   ParseConst('1.2');
166   AssertExpression('Float const', TheExpr,pekNumber,'1.2');
167 end;
168 
169 procedure TTestConstParser.DoTestSimpleStringConst;
170 begin
171   ParseConst('''test''');
172   AssertExpression('String const', TheExpr,pekString,'''test''');
173 end;
174 
175 procedure TTestConstParser.DoTestSimpleNilConst;
176 begin
177   ParseConst('Nil');
178   CheckExprNameKindClass(pekNil,TNilExpr);
179 end;
180 
181 procedure TTestConstParser.DoTestSimpleBoolConst;
182 begin
183   ParseConst('True');
184   CheckExprNameKindClass(pekBoolConst,TBoolconstExpr);
185   AssertEquals('Correct expression value',True,TBoolconstExpr(TheExpr).Value);
186 end;
187 
188 procedure TTestConstParser.DoTestSimpleIdentifierConst;
189 begin
190   ParseConst('taCenter');
191   AssertExpression('Enumeration const', theExpr,pekIdent,'taCenter');
192 end;
193 
194 procedure TTestConstParser.DoTestSimpleSetConst;
195 begin
196   ParseConst('[taLeftJustify,taRightJustify]');
197   CheckExprNameKindClass(pekSet,TParamsExpr);
198   AssertEquals('Correct set count',2,Length(TParamsExpr(TheExpr).Params));
199   AssertExpression('Set element 1',TParamsExpr(TheExpr).Params[0],pekIdent,'taLeftJustify');
200   AssertExpression('Set element 2',TParamsExpr(TheExpr).Params[1],pekIdent,'taRightJustify');
201 end;
202 
203 procedure TTestConstParser.DoTestSimpleExprConst;
204 
205 Var
206   B : TBinaryExpr;
207 
208 begin
209   ParseConst('1 + 2');
210   CheckExprNameKindClass(pekBinary,TBinaryExpr);
211   B:=TBinaryExpr(TheExpr);
212   TAssert.AssertSame('B.Left.Parent=B',B,B.left.Parent);
213   TAssert.AssertSame('B.right.Parent=B',B,B.right.Parent);
214   AssertExpression('Left expression',B.Left,pekNumber,'1');
215   AssertExpression('Right expression',B.Right,pekNumber,'2');
216 end;
217 
218 procedure TTestConstParser.TestSimpleIntConst;
219 begin
220   DoTestSimpleIntConst
221 end;
222 
223 procedure TTestConstParser.TestSimpleFloatConst;
224 begin
225   DoTestSimpleFloatConst
226 end;
227 
228 procedure TTestConstParser.TestSimpleStringConst;
229 begin
230   DoTestSimpleStringConst
231 end;
232 
233 procedure TTestConstParser.TestSimpleNilConst;
234 begin
235   DoTestSimpleNilConst
236 end;
237 
238 procedure TTestConstParser.TestSimpleBoolConst;
239 begin
240   DoTestSimpleBoolConst
241 end;
242 
243 procedure TTestConstParser.TestSimpleIdentifierConst;
244 begin
245   DoTestSimpleIdentifierConst
246 end;
247 
248 procedure TTestConstParser.TestSimpleSetConst;
249 begin
250   DoTestSimpleSetConst
251 end;
252 
253 procedure TTestConstParser.TestSimpleExprConst;
254 begin
255   DoTestSimpleExprConst;
256 end;
257 
258 procedure TTestConstParser.TestSimpleIntConstDeprecatedMsg;
259 begin
260   Hint:='deprecated ''this is old''' ;
261   DoTestSimpleIntConst;
262   CheckHint(hDeprecated);
263 end;
264 
265 procedure TTestConstParser.TestSimpleIntConstDeprecated;
266 begin
267   Hint:='deprecated';
268   DoTestSimpleIntConst;
269   CheckHint(hDeprecated);
270 end;
271 
272 procedure TTestConstParser.TestSimpleFloatConstDeprecated;
273 begin
274   Hint:='deprecated';
275   DoTestSimpleIntConst;
276   CheckHint(hDeprecated);
277 end;
278 
279 procedure TTestConstParser.TestSimpleStringConstDeprecated;
280 begin
281   Hint:='deprecated';
282   DoTestSimpleStringConst;
283   CheckHint(hDeprecated);
284 end;
285 
286 procedure TTestConstParser.TestSimpleNilConstDeprecated;
287 begin
288   Hint:='deprecated';
289   DoTestSimpleNilConst;
290   CheckHint(hDeprecated);
291 end;
292 
293 procedure TTestConstParser.TestSimpleBoolConstDeprecated;
294 begin
295   Hint:='deprecated';
296   DoTestSimpleBoolConst;
297   CheckHint(hDeprecated);
298 end;
299 
300 procedure TTestConstParser.TestSimpleIdentifierConstDeprecated;
301 begin
302   Hint:='deprecated';
303   DoTestSimpleIdentifierConst;
304   CheckHint(hDeprecated);
305 end;
306 
307 procedure TTestConstParser.TestSimpleSetConstDeprecated;
308 begin
309   Hint:='deprecated';
310   DoTestSimpleSetConst;
311   CheckHint(hDeprecated);
312 end;
313 
314 procedure TTestConstParser.TestSimpleExprConstDeprecated;
315 begin
316   Hint:='deprecated';
317   DoTestSimpleExprConst;
318   CheckHint(hDeprecated);
319 end;
320 
321 procedure TTestConstParser.TestSimpleIntConstPlatform;
322 begin
323   Hint:='Platform';
324   DoTestSimpleIntConst;
325   CheckHint(hPlatform);
326 end;
327 
328 procedure TTestConstParser.TestSimpleFloatConstPlatform;
329 begin
330   Hint:='Platform';
331   DoTestSimpleIntConst;
332   CheckHint(hPlatform);
333 end;
334 
335 procedure TTestConstParser.TestSimpleStringConstPlatform;
336 begin
337   Hint:='Platform';
338   DoTestSimpleStringConst;
339   CheckHint(hPlatform);
340 end;
341 
342 procedure TTestConstParser.TestSimpleNilConstPlatform;
343 begin
344   Hint:='Platform';
345   DoTestSimpleNilConst;
346   CheckHint(hPlatform);
347 end;
348 
349 procedure TTestConstParser.TestSimpleBoolConstPlatform;
350 begin
351   Hint:='Platform';
352   DoTestSimpleBoolConst;
353   CheckHint(hPlatform);
354 end;
355 
356 procedure TTestConstParser.TestSimpleIdentifierConstPlatform;
357 begin
358   Hint:='Platform';
359   DoTestSimpleIdentifierConst;
360   CheckHint(hPlatform);
361 end;
362 
363 procedure TTestConstParser.TestSimpleExprConstPlatform;
364 begin
365   Hint:='Platform';
366   DoTestSimpleExprConst;
367   CheckHint(hPlatform);
368 end;
369 
370 procedure TTestConstParser.TestSimpleSetConstPlatform;
371 begin
372   Hint:='Platform';
373   DoTestSimpleSetConst;
374   CheckHint(hPlatform);
375 end;
376 
377 procedure TTestConstParser.TestSimpleIntConstExperimental;
378 begin
379   Hint:='Experimental';
380   DoTestSimpleIntConst;
381   CheckHint(hExperimental);
382 end;
383 
384 procedure TTestConstParser.TestSimpleFloatConstExperimental;
385 begin
386   Hint:='Experimental';
387   DoTestSimpleIntConst;
388   CheckHint(hExperimental);
389 end;
390 
391 procedure TTestConstParser.TestSimpleStringConstExperimental;
392 begin
393   Hint:='Experimental';
394   DoTestSimpleStringConst;
395   CheckHint(hExperimental);
396 end;
397 
398 procedure TTestConstParser.TestSimpleNilConstExperimental;
399 begin
400   Hint:='Experimental';
401   DoTestSimpleNilConst;
402   CheckHint(hExperimental);
403 end;
404 
405 procedure TTestConstParser.TestSimpleBoolConstExperimental;
406 begin
407   Hint:='Experimental';
408   DoTestSimpleBoolConst;
409   CheckHint(hExperimental);
410 end;
411 
412 procedure TTestConstParser.TestSimpleIdentifierConstExperimental;
413 begin
414   Hint:='Experimental';
415   DoTestSimpleIdentifierConst;
416   CheckHint(hExperimental);
417 end;
418 
419 procedure TTestConstParser.TestSimpleSetConstExperimental;
420 begin
421   Hint:='Experimental';
422   DoTestSimpleSetConst;
423   CheckHint(hExperimental);
424 end;
425 
426 procedure TTestConstParser.TestSimpleExprConstExperimental;
427 begin
428   Hint:='Experimental';
429   DoTestSimpleExprConst;
430   CheckHint(hExperimental);
431 end;
432 
433 procedure TTestConstParser.TestTypedIntConst;
434 begin
435   Typed:='Integer';
436   DoTestSimpleIntConst
437 end;
438 
439 procedure TTestConstParser.TestTypedFloatConst;
440 begin
441   Typed:='Double';
442   DoTestSimpleFloatConst
443 end;
444 
445 procedure TTestConstParser.TestTypedStringConst;
446 begin
447   Typed:='shortstring';
448   DoTestSimpleStringConst
449 end;
450 
451 procedure TTestConstParser.TestTypedNilConst;
452 begin
453   Typed:='PChar';
454   DoTestSimpleNilConst
455 end;
456 
457 procedure TTestConstParser.TestTypedBoolConst;
458 begin
459   Typed:='Boolean';
460   DoTestSimpleBoolConst
461 end;
462 
463 procedure TTestConstParser.TestTypedIdentifierConst;
464 begin
465   Typed:='TAlign';
466   DoTestSimpleIdentifierConst
467 end;
468 
469 procedure TTestConstParser.TestTypedSetConst;
470 begin
471   Typed:='TAligns';
472   DoTestSimpleSetConst
473 end;
474 
475 procedure TTestConstParser.TestTypedExprConst;
476 begin
477   Typed:='ShortInt';
478   DoTestSimpleExprConst;
479 end;
480 
481 procedure TTestConstParser.TestRecordConst;
482 Var
483   R : TRecordValues;
484   Fi : TRecordValuesItem;
485 begin
486   Typed := 'TPoint';
487   ParseConst('(x:1;y: 2)');
488   AssertEquals('Record Values',TRecordValues,TheExpr.ClassType);
489   R:=TheExpr as TRecordValues;
490   AssertEquals('Expression list of ',pekListOfExp,TheExpr.Kind);
491   AssertEquals('2 elements',2,Length(R.Fields));
492   FI:=R.Fields[0];
493   AssertEquals('Name field 1','x',Fi.Name);
494   AssertExpression('Field 1 value',Fi.ValueExp,pekNumber,'1');
495   FI:=R.Fields[1];
496   AssertEquals('Name field 2','y',Fi.Name);
497   AssertExpression('Field 2 value',Fi.ValueExp,pekNumber,'2');
498 end;
499 
500 procedure TTestConstParser.TestArrayConst;
501 
502 Var
503   R : TArrayValues;
504 begin
505   Typed := 'TMyArray';
506   ParseConst('(1 , 2)');
507   AssertEquals('Array Values',TArrayValues,TheExpr.ClassType);
508   R:=TheExpr as TArrayValues;
509   AssertEquals('Expression list of ',pekListOfExp,TheExpr.Kind);
510   AssertEquals('2 elements',2,Length(R.Values));
511   AssertExpression('Element 1 value',R.Values[0],pekNumber,'1');
512   AssertExpression('Element 2 value',R.Values[1],pekNumber,'2');
513 end;
514 
515 procedure TTestConstParser.TestRangeConst;
516 begin
517   Typed:='0..1';
518   ParseConst('1');
519   AssertEquals('Range type',TPasRangeType,TheConst.VarType.ClassType);
520   AssertExpression('Float const', TheExpr,pekNumber,'1');
521 end;
522 
523 procedure TTestConstParser.DoParseConstUnTypedRange;
524 
525 begin
526   ParseConst('1..2');
527 end;
528 
529 procedure TTestConstParser.TestRangeConstUnTyped;
530 begin
531   AssertException('Range const is not allowed',EParserError,@DoParseConstUnTypedRange);
532 end;
533 
534 procedure TTestConstParser.TestArrayOfRangeConst;
535 Var
536   R : TArrayValues;
537 begin
538   Typed:='array [0..7] of 0..1';
539   ParseConst('(0, 0, 0, 0, 0, 0, 0, 0)');
540   AssertEquals('Array Values',TArrayValues,TheExpr.ClassType);
541   R:=TheExpr as TArrayValues;
542   AssertEquals('Expression list of ',pekListOfExp,TheExpr.Kind);
543   AssertEquals('elements',8,Length(R.Values));
544 //  AssertEquals('Range type',TPasRangeType,TheConst.VarType.ClassType);
545 //  AssertExpression('Float const', TheExpr,pekNumber,'1');
546 end;
547 
548 { TTestResourcestringParser }
549 
TTestResourcestringParser.ParseResourcestringnull550 function TTestResourcestringParser.ParseResourcestring(ASource: String
551   ): TPasResString;
552 
553 Var
554   D : String;
555 begin
556   Add('Resourcestring');
557   D:=' A = '+ASource;
558   If Hint<>'' then
559     D:=D+' '+Hint;
560   Add('  '+D+';');
561   Add('end.');
562   //Writeln(source.text);
563   ParseDeclarations;
564   AssertEquals('One resourcestring definition',1,Declarations.ResStrings.Count);
565   AssertEquals('First declaration is constant definition.',TPasResString,TObject(Declarations.ResStrings[0]).ClassType);
566   Result:=TPasResString(Declarations.ResStrings[0]);
567   FTheStr:=Result;
568   FExpr:=Result.Expr;
569   Definition:=Result;
570 end;
571 
572 procedure TTestResourcestringParser.CheckExprNameKindClass(AKind: TPasExprKind;
573   AClass: TClass);
574 begin
575   AssertEquals('Correct name','A',TheStr.Name);
576   AssertEquals('Correct expression kind',aKind,TheExpr.Kind);
577   AssertEquals('Correct expression class',AClass,TheExpr.ClassType);
578   // Writeln('Delcaration : ',TheStr.GetDeclaration(True));
579 end;
580 
581 procedure TTestResourcestringParser.DoTestSimple;
582 begin
583   ParseResourcestring('''Something''');
584   CheckExprNameKindClass(pekString,TPrimitiveExpr);
585   AssertEquals('Correct expression value','''Something''',TPrimitiveExpr(TheExpr).Value);
586 end;
587 
588 procedure TTestResourcestringParser.DoTestSum;
589 var
590   B: TBinaryExpr;
591 begin
592   ParseResourcestring('''Something''+'' else''');
593   CheckExprNameKindClass(pekBinary,TBinaryExpr);
594   B:=TBinaryExpr(TheExpr);
595   TAssert.AssertSame('B.left.parent=B',B,B.left.Parent);
596   TAssert.AssertSame('B.right.parent=B',B,B.right.Parent);
597   AssertEquals('Correct left',TPrimitiveExpr,B.Left.ClassType);
598   AssertEquals('Correct right',TPrimitiveExpr,B.Right.ClassType);
599   AssertEquals('Correct left expression value','''Something''',TPrimitiveExpr(B.Left).Value);
600   AssertEquals('Correct right expression value',''' else''',TPrimitiveExpr(B.Right).Value);
601 end;
602 
603 procedure TTestResourcestringParser.DoTestSum2;
604 var
605   B: TBinaryExpr;
606 begin
607   ParseResourcestring('''Something''+different');
608   CheckExprNameKindClass(pekBinary,TBinaryExpr);
609   B:=TBinaryExpr(TheExpr);
610   TAssert.AssertSame('B.left.parent=B',B,B.left.Parent);
611   TAssert.AssertSame('B.right.parent=B',B,B.right.Parent);
612   AssertEquals('Correct left',TPrimitiveExpr,B.Left.ClassType);
613   AssertEquals('Correct right',TPrimitiveExpr,B.Right.ClassType);
614   AssertEquals('Correct left expression value','''Something''',TPrimitiveExpr(B.Left).Value);
615   AssertEquals('Correct right expression value','different',TPrimitiveExpr(B.Right).Value);
616 end;
617 
618 procedure TTestResourcestringParser.TestSimple;
619 begin
620   DoTestSimple;
621 end;
622 
623 procedure TTestResourcestringParser.TestSimpleDeprecated;
624 begin
625   Hint:='deprecated';
626   DoTestSimple;
627   CheckHint(hDeprecated);
628 end;
629 
630 procedure TTestResourcestringParser.TestSimplePlatform;
631 begin
632   Hint:='platform';
633   DoTestSimple;
634   CheckHint(hPlatform);
635 end;
636 
637 procedure TTestResourcestringParser.TestSum2;
638 begin
639   DoTestSum2;
640 end;
641 
642 procedure TTestResourcestringParser.TestSum2Deprecated;
643 begin
644   Hint:='deprecated';
645   DoTestSum2;
646   CheckHint(hDeprecated);
647 end;
648 
649 procedure TTestResourcestringParser.TestSum2Platform;
650 begin
651   Hint:='platform';
652   DoTestSum2;
653   CheckHint(hplatform);
654 end;
655 procedure TTestResourcestringParser.TestSum1;
656 begin
657   DoTestSum;
658 end;
659 
660 procedure TTestResourcestringParser.TestSum1Deprecated;
661 begin
662   Hint:='deprecated';
663   DoTestSum;
664   CheckHint(hDeprecated);
665 end;
666 
667 procedure TTestResourcestringParser.TestSum1Platform;
668 begin
669   Hint:='platform';
670   DoTestSum;
671   CheckHint(hplatform);
672 end;
673 
674 initialization
675   RegisterTests([TTestConstParser,TTestResourcestringParser]);
676 
677 
678 end.
679 
680