1 {
2 This file is part of the Free Component Library (FCL)
3 Copyright (c) 2017 by Michael Van Canneyt
4
5 Unit tests for Pascal-to-Javascript converter class.
6
7 See the file COPYING.FPC, included in this distribution,
8 for details about the copyright.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************
15
16 Examples:
17 ./testpas2js --suite=TTestOptimizations
18 ./testpas2js --suite=TTestOptimizations.TestOmitLocalVar
19 }
20 unit tcoptimizations;
21
22 {$mode objfpc}{$H+}
23
24 interface
25
26 uses
27 Classes, SysUtils, testregistry, fppas2js, pastree,
28 PScanner, Pas2jsUseAnalyzer, PasResolver, PasResolveEval,
29 tcmodules;
30
31 type
32
33 { TCustomTestOptimizations }
34
35 TCustomTestOptimizations = class(TCustomTestModule)
36 private
37 FAnalyzerModule: TPas2JSAnalyzer;
38 FAnalyzerProgram: TPas2JSAnalyzer;
39 FWholeProgramOptimization: boolean;
OnConverterIsElementUsednull40 function OnConverterIsElementUsed(Sender: TObject; El: TPasElement): boolean;
OnConverterIsTypeInfoUsednull41 function OnConverterIsTypeInfoUsed(Sender: TObject; El: TPasElement): boolean;
42 protected
43 procedure SetUp; override;
44 procedure TearDown; override;
45 procedure ParseModule; override;
46 procedure ParseProgram; override;
CreateConverternull47 function CreateConverter: TPasToJSConverter; override;
48 public
49 property AnalyzerModule: TPas2JSAnalyzer read FAnalyzerModule;
50 property AnalyzerProgram: TPas2JSAnalyzer read FAnalyzerProgram;
51 property WholeProgramOptimization: boolean read FWholeProgramOptimization
52 write FWholeProgramOptimization;
53 end;
54
55 { TTestOptimizations }
56
57 TTestOptimizations = class(TCustomTestOptimizations)
58 published
59 // unit optimization: aliasglobals
60 procedure TestOptAliasGlobals_Program;
61 procedure TestOptAliasGlobals_Unit; // ToDo
62 // ToDo: external var, const, class
63 // ToDo: RTTI
64 // ToDo: typeinfo(var), typeinfo(type)
65 // ToDo: resourcestring
66 // ToDo: Global EnumType, EnumValue, EnumType.Value, unit.EnumType.Value
67 // ToDo: Nested EnumType: EnumValue, EnumType.Value, unit.aType.EnumType.Value, aType.EnumType.Value, Instance.EnumType.Value
68 // ToDo: Instance.RecordType, Instance.RecordType.ClassVar
69 // ToDo: ClassVarRecord
70
71 // Whole Program Optimization
72 procedure TestWPO_OmitLocalVar;
73 procedure TestWPO_OmitLocalProc;
74 procedure TestWPO_OmitLocalProcForward;
75 procedure TestWPO_OmitProcLocalVar;
76 procedure TestWPO_OmitProcLocalConst;
77 procedure TestWPO_OmitProcLocalType;
78 procedure TestWPO_OmitProcLocalProc;
79 procedure TestWPO_OmitProcLocalForwardProc;
80 procedure TestWPO_OmitRecordMember;
81 procedure TestWPO_OmitNotUsedTObject;
82 procedure TestWPO_TObject;
83 procedure TestWPO_Class_Property;
84 procedure TestWPO_Class_OmitField;
85 procedure TestWPO_Class_OmitMethod;
86 procedure TestWPO_Class_OmitClassMethod;
87 procedure TestWPO_Class_OmitPropertyGetter1;
88 procedure TestWPO_Class_OmitPropertyGetter2;
89 procedure TestWPO_Class_OmitPropertySetter1;
90 procedure TestWPO_Class_OmitPropertySetter2;
91 procedure TestWPO_Class_KeepNewInstance;
92 procedure TestWPO_CallInherited;
93 procedure TestWPO_UseUnit;
94 procedure TestWPO_ArrayOfConst_Use;
95 procedure TestWPO_ArrayOfConst_NotUsed;
96 procedure TestWPO_Class_PropertyInOtherUnit;
97 procedure TestWPO_ProgramPublicDeclaration;
98 procedure TestWPO_ConstructorDefaultValueConst;
99 procedure TestWPO_RTTI_PublishedField;
100 procedure TestWPO_RTTI_TypeInfo;
101 end;
102
103 implementation
104
105 { TCustomTestOptimizations }
106
TCustomTestOptimizations.OnConverterIsElementUsednull107 function TCustomTestOptimizations.OnConverterIsElementUsed(Sender: TObject;
108 El: TPasElement): boolean;
109 var
110 A: TPas2JSAnalyzer;
111 begin
112 if WholeProgramOptimization then
113 A:=AnalyzerProgram
114 else if Sender=Converter then
115 A:=AnalyzerModule
116 else
117 begin
118 {$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
119 writeln('TCustomTestOptimizations.OnConverterIsElementUsed El=',GetObjName(El),' WPO=',WholeProgramOptimization,' Sender=',GetObjName(Sender));
120 {$ENDIF}
121 Fail('converting other unit without WPO');
122 end;
123 Result:=A.IsUsed(El);
124 {$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
125 writeln('TCustomTestOptimizations.OnConverterIsElementUsed El=',GetObjName(El),' WPO=',WholeProgramOptimization,' Result=',Result);
126 {$ENDIF}
127 end;
128
TCustomTestOptimizations.OnConverterIsTypeInfoUsednull129 function TCustomTestOptimizations.OnConverterIsTypeInfoUsed(Sender: TObject;
130 El: TPasElement): boolean;
131 var
132 A: TPas2JSAnalyzer;
133 begin
134 if WholeProgramOptimization then
135 A:=AnalyzerProgram
136 else if Sender=Converter then
137 A:=AnalyzerModule
138 else
139 begin
140 {$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
141 writeln('TCustomTestOptimizations.OnConverterIsTypeInfoUsed El=',GetObjName(El),' WPO=',WholeProgramOptimization,' Sender=',GetObjName(Sender));
142 {$ENDIF}
143 Fail('converting other unit without WPO');
144 end;
145 Result:=A.IsTypeInfoUsed(El);
146 {$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
147 writeln('TCustomTestOptimizations.OnConverterIsTypeInfoUsed El=',GetObjName(El),' WPO=',WholeProgramOptimization,' Result=',Result);
148 {$ENDIF}
149 end;
150
151 procedure TCustomTestOptimizations.SetUp;
152 begin
153 inherited SetUp;
154 FWholeProgramOptimization:=false;
155 FAnalyzerModule:=TPas2JSAnalyzer.Create;
156 FAnalyzerModule.Resolver:=Engine;
157 FAnalyzerProgram:=TPas2JSAnalyzer.Create;
158 FAnalyzerProgram.Resolver:=Engine;
159 end;
160
161 procedure TCustomTestOptimizations.TearDown;
162 begin
163 FreeAndNil(FAnalyzerProgram);
164 FreeAndNil(FAnalyzerModule);
165 inherited TearDown;
166 end;
167
168 procedure TCustomTestOptimizations.ParseModule;
169 begin
170 inherited ParseModule;
171 {$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
172 writeln('TCustomTestOptimizations.ParseModule START');
173 {$ENDIF}
174 AnalyzerModule.AnalyzeModule(Module);
175 {$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
176 writeln('TCustomTestOptimizations.ParseModule END');
177 {$ENDIF}
178 end;
179
180 procedure TCustomTestOptimizations.ParseProgram;
181 begin
182 WholeProgramOptimization:=true;
183 inherited ParseProgram;
184 {$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
185 writeln('TCustomTestOptimizations.ParseProgram START');
186 {$ENDIF}
187 AnalyzerProgram.AnalyzeWholeProgram(Module as TPasProgram);
188 {$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
189 writeln('TCustomTestOptimizations.ParseProgram START');
190 {$ENDIF}
191 end;
192
CreateConverternull193 function TCustomTestOptimizations.CreateConverter: TPasToJSConverter;
194 begin
195 Result:=inherited CreateConverter;
196 Result.OnIsElementUsed:=@OnConverterIsElementUsed;
197 Result.OnIsTypeInfoUsed:=@OnConverterIsTypeInfoUsed;
198 end;
199
200 { TTestOptimizations }
201
202 procedure TTestOptimizations.TestOptAliasGlobals_Program;
203 begin
204 AddModuleWithIntfImplSrc('UnitA.pas',
205 LinesToStr([
206 'const',
207 ' cWidth = 17;',
208 'type',
209 ' TBird = class',
210 ' public',
211 ' class var c: word;',
212 ' class function Run(w: word): word; virtual; abstract;',
213 ' end;',
214 ' TRec = record',
215 ' x: word;',
216 ' end;',
217 'var b: TBird;',
218 '']),
219 LinesToStr([
220 '']));
221
222 StartProgram(true,[supTObject]);
223 Add([
224 '{$optimization AliasGlobals}',
225 'uses unita;',
226 'type',
227 ' TEagle = class(TBird)',
228 ' class function Run(w: word = 5): word; override;',
229 ' end;',
230 'class function TEagle.Run(w: word): word;',
231 'begin',
232 'end;',
233 'var',
234 ' e: TEagle;',
235 ' r: TRec;',
236 'begin',
237 ' e:=TEagle.Create;',
238 ' b:=TBird.Create;',
239 ' e.c:=e.c+1;',
240 ' r.x:=TBird.c;',
241 ' r.x:=b.c;',
242 ' r.x:=e.Run;',
243 ' r.x:=e.Run();',
244 ' r.x:=e.Run(4);',
245 '']);
246 ConvertProgram;
247 CheckSource('TestOptAliasGlobals_Program',
248 LinesToStr([
249 'var $lmr = pas.UnitA;',
250 'var $ltr = $lmr.TBird;',
251 'var $ltr1 = $lmr.TRec;',
252 'rtl.createClass($mod, "TEagle", $ltr, function () {',
253 ' this.Run = function (w) {',
254 ' var Result = 0;',
255 ' return Result;',
256 ' };',
257 '});',
258 'this.e = null;',
259 'this.r = $ltr1.$new();',
260 '']),
261 LinesToStr([
262 '$mod.e = $mod.TEagle.$create("Create");',
263 '$lmr.b = $ltr.$create("Create");',
264 '$ltr.c = $mod.e.c + 1;',
265 '$mod.r.x = $ltr.c;',
266 '$mod.r.x = $lmr.b.c;',
267 '$mod.r.x = $mod.e.$class.Run(5);',
268 '$mod.r.x = $mod.e.$class.Run(5);',
269 '$mod.r.x = $mod.e.$class.Run(4);',
270 '']));
271 end;
272
273 procedure TTestOptimizations.TestOptAliasGlobals_Unit;
274 begin
275 exit;
276
277 AddModuleWithIntfImplSrc('UnitA.pas',
278 LinesToStr([
279 'const',
280 ' cWidth = 17;',
281 'type',
282 ' TBird = class',
283 ' public',
284 ' class var Span: word;',
285 ' class procedure Fly(w: word); virtual; abstract;',
286 ' end;',
287 ' TRecA = record',
288 ' x: word;',
289 ' end;',
290 'var Bird: TBird;',
291 '']),
292 LinesToStr([
293 '']));
294 AddModuleWithIntfImplSrc('UnitB.pas',
295 LinesToStr([
296 'const',
297 ' cHeight = 23;',
298 'type',
299 ' TAnt = class',
300 ' public',
301 ' class var Legs: word;',
302 ' class procedure Run(w: word); virtual; abstract;',
303 ' end;',
304 ' TRecB = record',
305 ' y: word;',
306 ' end;',
307 'var Ant: TAnt;',
308 '']),
309 LinesToStr([
310 '']));
311 StartUnit(true,[supTObject]);
312 Add([
313 '{$optimization AliasGlobals}',
314 'interface',
315 'uses unita;',
316 'type',
317 ' TEagle = class(TBird)',
318 ' class var EagleRec: TRecA;',
319 ' class procedure Fly(w: word = 5); override;',
320 ' end;',
321 'implementation',
322 'uses unitb;',
323 'type',
324 ' TRedAnt = class(TAnt)',
325 ' class var RedAntRecA: TRecA;',
326 ' class var RedAntRecB: TRecB;',
327 ' class procedure Run(w: word = 6); override;',
328 ' end;',
329 'class procedure TEagle.Fly(w: word);',
330 'begin',
331 'end;',
332 'class procedure TRedAnt.Run(w: word);',
333 'begin',
334 'end;',
335 'var',
336 ' Eagle: TEagle;',
337 ' RedAnt: TRedAnt;',
338 'initialization',
339 ' Eagle:=TEagle.Create;',
340 ' RedAnt:=TRedAnt.Create;',
341 ' Bird:=TBird.Create;',
342 ' Ant:=TAnt.Create;',
343 ' TRedAnt.RedAntRecA.x:=TRedAnt.RedAntRecB.y;',
344 '']);
345 ConvertUnit;
346 CheckSource('TestOptAliasGlobals_Unit',
347 LinesToStr([
348 '']),
349 LinesToStr([
350 '']));
351 end;
352
353 procedure TTestOptimizations.TestWPO_OmitLocalVar;
354 begin
355 StartProgram(false);
356 Add('var');
357 Add(' a: longint;');
358 Add(' b: longint;');
359 Add('begin');
360 Add(' b:=3;');
361 ConvertProgram;
362 CheckSource('TestWPO_OmitLocalVar',
363 'this.b = 0;',
364 '$mod.b = 3;');
365 end;
366
367 procedure TTestOptimizations.TestWPO_OmitLocalProc;
368 begin
369 StartProgram(false);
370 Add('procedure DoIt; begin end;');
371 Add('procedure NoIt; begin end;');
372 Add('begin');
373 Add(' DoIt;');
374 ConvertProgram;
375 CheckSource('TestWPO_OmitLocalProc',
376 LinesToStr([
377 'this.DoIt = function () {',
378 '};',
379 '']),
380 LinesToStr([
381 '$mod.DoIt();',
382 '']));
383 end;
384
385 procedure TTestOptimizations.TestWPO_OmitLocalProcForward;
386 begin
387 StartProgram(false);
388 Add('procedure DoIt; forward;');
389 Add('procedure NoIt; forward;');
390 Add('procedure DoIt; begin end;');
391 Add('procedure NoIt; begin end;');
392 Add('begin');
393 Add(' DoIt;');
394 ConvertProgram;
395 CheckSource('TestWPO_OmitLocalProcForward',
396 LinesToStr([
397 'this.DoIt = function () {',
398 '};',
399 '']),
400 LinesToStr([
401 '$mod.DoIt();',
402 '']));
403 end;
404
405 procedure TTestOptimizations.TestWPO_OmitProcLocalVar;
406 begin
407 StartProgram(false);
408 Add('function DoIt: longint;');
409 Add('var');
410 Add(' a: longint;');
411 Add(' b: longint;');
412 Add('begin');
413 Add(' b:=3;');
414 Add(' Result:=b;');
415 Add('end;');
416 Add('begin');
417 Add(' DoIt;');
418 ConvertProgram;
419 CheckSource('TestWPO_OmitProcLocalVar',
420 LinesToStr([
421 'this.DoIt = function () {',
422 ' var Result = 0;',
423 ' var b = 0;',
424 ' b = 3;',
425 ' Result = b;',
426 ' return Result;',
427 '};',
428 '']),
429 LinesToStr([
430 '$mod.DoIt();',
431 '']));
432 end;
433
434 procedure TTestOptimizations.TestWPO_OmitProcLocalConst;
435 begin
436 StartProgram(false);
437 Add('function DoIt: longint;');
438 Add('const');
439 Add(' a = 3;');
440 Add(' b = 4;');
441 Add(' c: longint = 5;');
442 Add(' d: longint = 6;');
443 Add('begin');
444 Add(' Result:=b+d;');
445 Add('end;');
446 Add('begin');
447 Add(' DoIt;');
448 ConvertProgram;
449 CheckSource('TestWPO_OmitProcLocalConst',
450 LinesToStr([
451 'var b = 4;',
452 'var d = 6;',
453 'this.DoIt = function () {',
454 ' var Result = 0;',
455 ' Result = 4 + d;',
456 ' return Result;',
457 '};',
458 '']),
459 LinesToStr([
460 '$mod.DoIt();',
461 '']));
462 end;
463
464 procedure TTestOptimizations.TestWPO_OmitProcLocalType;
465 begin
466 StartProgram(false);
467 Add('function DoIt: longint;');
468 Add('type');
469 Add(' TEnum = (red, green);');
470 Add(' TEnums = set of TEnum;');
471 Add('begin');
472 Add(' Result:=3;');
473 Add('end;');
474 Add('begin');
475 Add(' DoIt;');
476 ConvertProgram;
477 CheckSource('TestWPO_OmitProcLocalType',
478 LinesToStr([
479 'this.DoIt = function () {',
480 ' var Result = 0;',
481 ' Result = 3;',
482 ' return Result;',
483 '};',
484 '']),
485 LinesToStr([
486 '$mod.DoIt();',
487 '']));
488 end;
489
490 procedure TTestOptimizations.TestWPO_OmitProcLocalProc;
491 begin
492 StartProgram(false);
493 Add('procedure DoIt;');
494 Add(' procedure SubProcA; begin end;');
495 Add(' procedure SubProcB; begin end;');
496 Add('begin');
497 Add(' SubProcB;');
498 Add('end;');
499 Add('begin');
500 Add(' DoIt;');
501 ConvertProgram;
502 CheckSource('TestWPO_OmitProcLocalProc',
503 LinesToStr([
504 'this.DoIt = function () {',
505 ' function SubProcB() {',
506 ' };',
507 ' SubProcB();',
508 '};',
509 '']),
510 LinesToStr([
511 '$mod.DoIt();',
512 '']));
513 end;
514
515 procedure TTestOptimizations.TestWPO_OmitProcLocalForwardProc;
516 begin
517 StartProgram(false);
518 Add('procedure DoIt;');
519 Add(' procedure SubProcA; forward;');
520 Add(' procedure SubProcB; forward;');
521 Add(' procedure SubProcA; begin end;');
522 Add(' procedure SubProcB; begin end;');
523 Add('begin');
524 Add(' SubProcB;');
525 Add('end;');
526 Add('begin');
527 Add(' DoIt;');
528 ConvertProgram;
529 CheckSource('TestWPO_OmitProcLocalForwardProc',
530 LinesToStr([
531 'this.DoIt = function () {',
532 ' function SubProcB() {',
533 ' };',
534 ' SubProcB();',
535 '};',
536 '']),
537 LinesToStr([
538 '$mod.DoIt();',
539 '']));
540 end;
541
542 procedure TTestOptimizations.TestWPO_OmitRecordMember;
543 begin
544 StartProgram(false);
545 Add('type');
546 Add(' TRec = record');
547 Add(' a: longint;');
548 Add(' b: longint;');
549 Add(' end;');
550 Add('var r: TRec;');
551 Add('begin');
552 Add(' r.a:=3;');
553 ConvertProgram;
554 CheckSource('TestWPO_OmitRecordMember',
555 LinesToStr([
556 'rtl.recNewT($mod, "TRec", function () {',
557 ' this.a = 0;',
558 ' this.$eq = function (b) {',
559 ' return this.a === b.a;',
560 ' };',
561 ' this.$assign = function (s) {',
562 ' this.a = s.a;',
563 ' return this;',
564 ' };',
565 '});',
566 'this.r = $mod.TRec.$new();',
567 '']),
568 LinesToStr([
569 '$mod.r.a = 3;',
570 '']));
571 end;
572
573 procedure TTestOptimizations.TestWPO_OmitNotUsedTObject;
574 begin
575 StartProgram(false);
576 Add('type');
577 Add(' TObject = class end;');
578 Add('var o: TObject;');
579 Add('begin');
580 ConvertProgram;
581 CheckSource('TestWPO_OmitNotUsedTObject',
582 LinesToStr([
583 '']),
584 LinesToStr([
585 '']));
586 end;
587
588 procedure TTestOptimizations.TestWPO_TObject;
589 begin
590 StartProgram(false);
591 Add('type');
592 Add(' TObject = class');
593 Add(' procedure AfterConstruction; virtual;');
594 Add(' procedure BeforeDestruction; virtual;');
595 Add(' end;');
596 Add('procedure TObject.AfterConstruction; begin end;');
597 Add('procedure TObject.BeforeDestruction; begin end;');
598 Add('var o: TObject;');
599 Add('begin');
600 Add(' o:=nil;');
601 ConvertProgram;
602 CheckSource('TestWPO_TObject',
603 LinesToStr([
604 'rtl.createClass($mod, "TObject", null, function () {',
605 ' this.$init = function () {',
606 ' };',
607 ' this.$final = function () {',
608 ' };',
609 ' this.AfterConstruction = function () {',
610 ' };',
611 ' this.BeforeDestruction = function () {',
612 ' };',
613 '});',
614 'this.o = null;',
615 '']),
616 LinesToStr([
617 '$mod.o = null;']));
618 end;
619
620 procedure TTestOptimizations.TestWPO_Class_Property;
621 begin
622 StartProgram(false);
623 Add([
624 'type',
625 ' TObject = class',
626 ' private',
627 ' const CA = 3;',
628 ' private',
629 ' FA: longint;',
630 ' function GetA: longint;',
631 ' procedure SetA(Value: longint);',
632 ' function IsStoredA: boolean;',
633 ' property A: longint read GetA write SetA stored IsStoredA default CA;',
634 ' end;',
635 'function tobject.geta: longint; begin end;',
636 'procedure tobject.seta(value: longint); begin end;',
637 'function tobject.isstoreda: boolean; begin end;',
638 'var o: TObject;',
639 'begin',
640 ' o.A:=o.A;']);
641 ConvertProgram;
642 CheckSource('TestWPO_Class_TObject',
643 LinesToStr([
644 'rtl.createClass($mod, "TObject", null, function () {',
645 ' this.$init = function () {',
646 ' };',
647 ' this.$final = function () {',
648 ' };',
649 ' this.GetA = function () {',
650 ' var Result = 0;',
651 ' return Result;',
652 ' };',
653 ' this.SetA = function (Value) {',
654 ' };',
655 '});',
656 'this.o = null;',
657 '']),
658 LinesToStr([
659 '$mod.o.SetA($mod.o.GetA());']));
660 end;
661
662 procedure TTestOptimizations.TestWPO_Class_OmitField;
663 begin
664 StartProgram(false);
665 Add('type');
666 Add(' TObject = class');
667 Add(' a: longint;');
668 Add(' b: longint;');
669 Add(' end;');
670 Add('var o: TObject;');
671 Add('begin');
672 Add(' o.a:=3;');
673 ConvertProgram;
674 CheckSource('TestWPO_OmitClassField',
675 LinesToStr([
676 'rtl.createClass($mod, "TObject", null, function () {',
677 ' this.$init = function () {',
678 ' this.a = 0;',
679 ' };',
680 ' this.$final = function () {',
681 ' };',
682 '});',
683 'this.o = null;',
684 '']),
685 LinesToStr([
686 '$mod.o.a = 3;']));
687 end;
688
689 procedure TTestOptimizations.TestWPO_Class_OmitMethod;
690 begin
691 StartProgram(false);
692 Add('type');
693 Add(' TObject = class');
694 Add(' procedure ProcA;');
695 Add(' procedure ProcB;');
696 Add(' end;');
697 Add('procedure TObject.ProcA; begin end;');
698 Add('procedure TObject.ProcB; begin end;');
699 Add('var o: TObject;');
700 Add('begin');
701 Add(' o.ProcB;');
702 ConvertProgram;
703 CheckSource('TestWPO_OmitClassMethod',
704 LinesToStr([
705 'rtl.createClass($mod, "TObject", null, function () {',
706 ' this.$init = function () {',
707 ' };',
708 ' this.$final = function () {',
709 ' };',
710 ' this.ProcB = function () {',
711 ' };',
712 '});',
713 'this.o = null;',
714 '']),
715 LinesToStr([
716 '$mod.o.ProcB();']));
717 end;
718
719 procedure TTestOptimizations.TestWPO_Class_OmitClassMethod;
720 begin
721 StartProgram(false);
722 Add('type');
723 Add(' TObject = class');
724 Add(' class procedure ProcA;');
725 Add(' class procedure ProcB;');
726 Add(' end;');
727 Add('class procedure TObject.ProcA; begin end;');
728 Add('class procedure TObject.ProcB; begin end;');
729 Add('var o: TObject;');
730 Add('begin');
731 Add(' o.ProcB;');
732 ConvertProgram;
733 CheckSource('TestWPO_OmitClassMethod',
734 LinesToStr([
735 'rtl.createClass($mod, "TObject", null, function () {',
736 ' this.$init = function () {',
737 ' };',
738 ' this.$final = function () {',
739 ' };',
740 ' this.ProcB = function () {',
741 ' };',
742 '});',
743 'this.o = null;',
744 '']),
745 LinesToStr([
746 '$mod.o.$class.ProcB();']));
747 end;
748
749 procedure TTestOptimizations.TestWPO_Class_OmitPropertyGetter1;
750 begin
751 StartProgram(false);
752 Add('type');
753 Add(' TObject = class');
754 Add(' FFoo: boolean;');
755 Add(' function GetFoo: boolean;');
756 Add(' property Foo: boolean read FFoo;');
757 Add(' property Foo2: boolean read GetFoo;');
758 Add(' FBar: boolean;');
759 Add(' function GetBar: boolean;');
760 Add(' property Bar: boolean read FBar;');
761 Add(' property Bar2: boolean read GetBar;');
762 Add(' end;');
763 Add('function TObject.GetFoo: boolean; begin Result:=FFoo; end;');
764 Add('function TObject.GetBar: boolean; begin Result:=FBar; end;');
765 Add('var o: TObject;');
766 Add('begin');
767 Add(' if o.Foo then;');
768 ConvertProgram;
769 CheckSource('TestWPO_OmitClassPropertyGetter1',
770 LinesToStr([
771 'rtl.createClass($mod, "TObject", null, function () {',
772 ' this.$init = function () {',
773 ' this.FFoo = false;',
774 ' };',
775 ' this.$final = function () {',
776 ' };',
777 '});',
778 'this.o = null;',
779 '']),
780 LinesToStr([
781 'if ($mod.o.FFoo);',
782 '']));
783 end;
784
785 procedure TTestOptimizations.TestWPO_Class_OmitPropertyGetter2;
786 begin
787 StartProgram(false);
788 Add('type');
789 Add(' TObject = class');
790 Add(' FFoo: boolean;');
791 Add(' function GetFoo: boolean;');
792 Add(' property Foo: boolean read FFoo;');
793 Add(' property Foo2: boolean read GetFoo;');
794 Add(' end;');
795 Add('function TObject.GetFoo: boolean; begin Result:=FFoo; end;');
796 Add('var o: TObject;');
797 Add('begin');
798 Add(' if o.Foo2 then;');
799 ConvertProgram;
800 CheckSource('TestWPO_OmitClassPropertyGetter2',
801 LinesToStr([
802 'rtl.createClass($mod, "TObject", null, function () {',
803 ' this.$init = function () {',
804 ' this.FFoo = false;',
805 ' };',
806 ' this.$final = function () {',
807 ' };',
808 ' this.GetFoo = function () {',
809 ' var Result = false;',
810 ' Result = this.FFoo;',
811 ' return Result;',
812 ' };',
813 '});',
814 'this.o = null;',
815 '']),
816 LinesToStr([
817 'if ($mod.o.GetFoo()) ;',
818 '']));
819 end;
820
821 procedure TTestOptimizations.TestWPO_Class_OmitPropertySetter1;
822 begin
823 StartProgram(false);
824 Add('type');
825 Add(' TObject = class');
826 Add(' FFoo: boolean;');
827 Add(' procedure SetFoo(Value: boolean);');
828 Add(' property Foo: boolean write FFoo;');
829 Add(' property Foo2: boolean write SetFoo;');
830 Add(' FBar: boolean;');
831 Add(' procedure SetBar(Value: boolean);');
832 Add(' property Bar: boolean write FBar;');
833 Add(' property Bar2: boolean write SetBar;');
834 Add(' end;');
835 Add('procedure TObject.SetFoo(Value: boolean); begin FFoo:=Value; end;');
836 Add('procedure TObject.SetBar(Value: boolean); begin FBar:=Value; end;');
837 Add('var o: TObject;');
838 Add('begin');
839 Add(' o.Foo:=true;');
840 ConvertProgram;
841 CheckSource('TestWPO_OmitClassPropertySetter1',
842 LinesToStr([
843 'rtl.createClass($mod, "TObject", null, function () {',
844 ' this.$init = function () {',
845 ' this.FFoo = false;',
846 ' };',
847 ' this.$final = function () {',
848 ' };',
849 '});',
850 'this.o = null;',
851 '']),
852 LinesToStr([
853 '$mod.o.FFoo = true;',
854 '']));
855 end;
856
857 procedure TTestOptimizations.TestWPO_Class_OmitPropertySetter2;
858 begin
859 StartProgram(false);
860 Add('type');
861 Add(' TObject = class');
862 Add(' FFoo: boolean;');
863 Add(' procedure SetFoo(Value: boolean);');
864 Add(' property Foo: boolean write FFoo;');
865 Add(' property Foo2: boolean write SetFoo;');
866 Add(' end;');
867 Add('procedure TObject.SetFoo(Value: boolean); begin FFoo:=Value; end;');
868 Add('var o: TObject;');
869 Add('begin');
870 Add(' o.Foo2:=true;');
871 ConvertProgram;
872 CheckSource('TestWPO_OmitClassPropertySetter2',
873 LinesToStr([
874 'rtl.createClass($mod, "TObject", null, function () {',
875 ' this.$init = function () {',
876 ' this.FFoo = false;',
877 ' };',
878 ' this.$final = function () {',
879 ' };',
880 ' this.SetFoo = function (Value) {',
881 ' this.FFoo = Value;',
882 ' };',
883 '});',
884 'this.o = null;',
885 '']),
886 LinesToStr([
887 '$mod.o.SetFoo(true);',
888 '']));
889 end;
890
891 procedure TTestOptimizations.TestWPO_Class_KeepNewInstance;
892 begin
893 StartProgram(false);
894 Add([
895 '{$modeswitch externalclass}',
896 'type',
897 ' TExt = class external name ''Object''',
898 ' end;',
899 ' TBird = class(TExt)',
900 ' protected',
901 ' class function NewInstance(fnname: string; const paramarray): TBird; virtual;',
902 ' public',
903 ' constructor Create;',
904 ' end;',
905 'class function TBird.NewInstance(fnname: string; const paramarray): TBird;',
906 'begin',
907 ' asm',
908 ' Result = Object.create();',
909 ' end;',
910 'end;',
911 'constructor TBird.Create;',
912 'begin',
913 ' inherited;',
914 'end;',
915 'begin',
916 ' TBird.Create;',
917 '']);
918 ConvertProgram;
919 CheckSource('TestWPO_Class_KeepNewInstance',
920 LinesToStr([
921 'rtl.createClassExt($mod, "TBird", Object, "NewInstance", function () {',
922 ' this.$init = function () {',
923 ' };',
924 ' this.$final = function () {',
925 ' };',
926 ' this.NewInstance = function (fnname, paramarray) {',
927 ' var Result = null;',
928 ' Result = Object.create();',
929 ' return Result;',
930 ' };',
931 ' this.Create = function () {',
932 ' return this;',
933 ' };',
934 '});',
935 '']),
936 LinesToStr([
937 '$mod.TBird.$create("Create");',
938 '']));
939 end;
940
941 procedure TTestOptimizations.TestWPO_CallInherited;
942 begin
943 StartProgram(false);
944 Add('type');
945 Add(' TObject = class');
946 Add(' procedure DoA;');
947 Add(' procedure DoB;');
948 Add(' end;');
949 Add(' TMobile = class');
950 Add(' procedure DoA;');
951 Add(' procedure DoC;');
952 Add(' end;');
953 Add('procedure TObject.DoA; begin end;');
954 Add('procedure TObject.DoB; begin end;');
955 Add('procedure TMobile.DoA;');
956 Add('begin');
957 Add(' inherited;');
958 Add('end;');
959 Add('procedure TMobile.DoC;');
960 Add('begin');
961 Add(' inherited DoB;');
962 Add('end;');
963 Add('var o: TMobile;');
964 Add('begin');
965 Add(' o.DoA;');
966 Add(' o.DoC;');
967 ConvertProgram;
968 CheckSource('TestWPO_CallInherited',
969 LinesToStr([
970 'rtl.createClass($mod, "TObject", null, function () {',
971 ' this.$init = function () {',
972 ' };',
973 ' this.$final = function () {',
974 ' };',
975 ' this.DoA = function () {',
976 ' };',
977 ' this.DoB = function () {',
978 ' };',
979 '});',
980 ' rtl.createClass($mod, "TMobile", $mod.TObject, function () {',
981 ' this.DoA$1 = function () {',
982 ' $mod.TObject.DoA.call(this);',
983 ' };',
984 ' this.DoC = function () {',
985 ' $mod.TObject.DoB.call(this);',
986 ' };',
987 '});',
988 'this.o = null;',
989 '']),
990 LinesToStr([
991 '$mod.o.DoA$1();',
992 '$mod.o.DoC();',
993 '']));
994 end;
995
996 procedure TTestOptimizations.TestWPO_UseUnit;
997 var
998 ActualSrc, ExpectedSrc: String;
999 begin
1000 AddModuleWithIntfImplSrc('unit1.pp',
1001 LinesToStr([
1002 'var i: longint;',
1003 'procedure DoIt;',
1004 '']),
1005 LinesToStr([
1006 'procedure DoIt; begin end;']));
1007
1008 AddModuleWithIntfImplSrc('unit2.pp',
1009 LinesToStr([
1010 'var j: longint;',
1011 'procedure DoMore;',
1012 '']),
1013 LinesToStr([
1014 'procedure DoMore; begin end;']));
1015
1016 StartProgram(true);
1017 Add('uses unit2;');
1018 Add('begin');
1019 Add(' j:=3;');
1020 ConvertProgram;
1021 ActualSrc:=ConvertJSModuleToString(JSModule);
1022 ExpectedSrc:=LinesToStr([
1023 'rtl.module("program", ["system", "unit2"], function () {',
1024 ' var $mod = this;',
1025 ' $mod.$main = function () {',
1026 ' pas.unit2.j = 3;',
1027 ' };',
1028 '});',
1029 '']);
1030 CheckDiff('TestWPO_UseUnit',ExpectedSrc,ActualSrc);
1031 end;
1032
1033 procedure TTestOptimizations.TestWPO_ArrayOfConst_Use;
1034 begin
1035 StartProgram(true,[supTVarRec]);
1036 Add([
1037 'procedure Say(arr: array of const);',
1038 'begin',
1039 'end;',
1040 'begin',
1041 ' Say([true]);']);
1042 ConvertProgram;
1043 CheckUnit('system.pp',
1044 LinesToStr([
1045 'rtl.module("system", [], function () {',
1046 ' var $mod = this;',
1047 ' rtl.recNewT($mod, "TVarRec", function () {',
1048 ' this.VType = 0;',
1049 ' this.VJSValue = undefined;',
1050 ' this.$eq = function (b) {',
1051 ' return (this.VType === b.VType) && (this.VJSValue === b.VJSValue);',
1052 ' };',
1053 ' this.$assign = function (s) {',
1054 ' this.VType = s.VType;',
1055 ' this.VJSValue = s.VJSValue;',
1056 ' return this;',
1057 ' };',
1058 ' });',
1059 ' this.VarRecs = function () {',
1060 ' var Result = [];',
1061 ' var v = null;',
1062 ' v.VType = 1;',
1063 ' v.VJSValue = 2;',
1064 ' return Result;',
1065 ' };',
1066 '});',
1067 '']));
1068 end;
1069
1070 procedure TTestOptimizations.TestWPO_ArrayOfConst_NotUsed;
1071 begin
1072 StartProgram(true,[supTVarRec]);
1073 Add([
1074 'procedure Say(arr: array of const);',
1075 'begin',
1076 'end;',
1077 'begin']);
1078 ConvertProgram;
1079 CheckUnit('system.pp',
1080 LinesToStr([
1081 'rtl.module("system", [], function () {',
1082 ' var $mod = this;',
1083 '});',
1084 '']));
1085 end;
1086
1087 procedure TTestOptimizations.TestWPO_Class_PropertyInOtherUnit;
1088 begin
1089 AddModuleWithIntfImplSrc('unit1.pp',
1090 LinesToStr([
1091 'type',
1092 ' TObject = class',
1093 ' private',
1094 ' const CA = 3;',
1095 ' private',
1096 ' FOther: string;',
1097 ' FA: longint;',
1098 ' function GetA: longint;',
1099 ' procedure SetA(Value: longint);',
1100 ' function IsStoredA: boolean;',
1101 ' public',
1102 ' property A: longint read GetA write SetA stored IsStoredA default CA;',
1103 ' end;',
1104 '']),
1105 LinesToStr([
1106 'function TObject.geta: longint;',
1107 'begin',
1108 'end;',
1109 'procedure TObject.seta(value: longint);',
1110 'begin',
1111 ' FA:=Value;',
1112 'end;',
1113 'function TObject.isstoreda: boolean; begin end;',
1114 '']));
1115 StartProgram(true);
1116 Add([
1117 'uses unit1;',
1118 'var o: TObject;',
1119 'begin',
1120 ' o.A:=o.A;']);
1121 ConvertProgram;
1122 CheckUnit('unit1.pp',
1123 LinesToStr([
1124 'rtl.module("unit1", ["system"], function () {',
1125 ' var $mod = this;',
1126 ' rtl.createClass($mod, "TObject", null, function () {',
1127 ' this.$init = function () {',
1128 ' this.FA = 0;',
1129 ' };',
1130 ' this.$final = function () {',
1131 ' };',
1132 ' this.GetA = function () {',
1133 ' var Result = 0;',
1134 ' return Result;',
1135 ' };',
1136 ' this.SetA = function (Value) {',
1137 ' this.FA = Value;',
1138 ' };',
1139 ' });',
1140 '});',
1141 '']));
1142 end;
1143
1144 procedure TTestOptimizations.TestWPO_ProgramPublicDeclaration;
1145 var
1146 ActualSrc, ExpectedSrc: String;
1147 begin
1148 StartProgram(true);
1149 Add('var');
1150 Add(' vPublic: longint; public;');
1151 Add(' vPrivate: longint;');
1152 Add('procedure DoPublic; public; begin end;');
1153 Add('procedure DoPrivate; begin end;');
1154 Add('begin');
1155 ConvertProgram;
1156 ActualSrc:=ConvertJSModuleToString(JSModule);
1157 ExpectedSrc:=LinesToStr([
1158 'rtl.module("program", ["system"], function () {',
1159 ' var $mod = this;',
1160 ' this.vPublic = 0;',
1161 ' this.DoPublic =function(){',
1162 ' };',
1163 ' $mod.$main = function () {',
1164 ' };',
1165 '});',
1166 '']);
1167 CheckDiff('TestWPO_ProgramPublicDeclaration',ExpectedSrc,ActualSrc);
1168 end;
1169
1170 procedure TTestOptimizations.TestWPO_ConstructorDefaultValueConst;
1171 var
1172 ActualSrc, ExpectedSrc: String;
1173 begin
1174 Converter.Options:=Converter.Options-[coNoTypeInfo];
1175 StartProgram(true);
1176 Add([
1177 'const gcBlack = 0;',
1178 'type',
1179 ' TColor = longint;',
1180 ' TObject = class',
1181 ' private',
1182 ' FColor: TColor;',
1183 ' public',
1184 ' property Color: TColor read FColor write FColor;',
1185 ' constructor Create(const AColor: TColor = gcBlack);',
1186 ' end;',
1187 'constructor TObject.Create(const AColor: TColor = gcBlack);',
1188 'begin',
1189 ' FColor := AColor;',
1190 'end;',
1191 'var T: TObject;',
1192 'begin',
1193 ' T := TObject.Create;',
1194 '']);
1195 ConvertProgram;
1196 ActualSrc:=ConvertJSModuleToString(JSModule);
1197 ExpectedSrc:=LinesToStr([
1198 'rtl.module("program",["system"],function () {',
1199 ' var $mod = this;',
1200 ' this.gcBlack = 0;',
1201 ' rtl.createClass($mod,"TObject",null,function () {',
1202 ' this.$init = function () {',
1203 ' this.FColor = 0;',
1204 ' };',
1205 ' this.$final = function () {',
1206 ' };',
1207 ' this.Create = function (AColor) {',
1208 ' this.FColor = AColor;',
1209 ' return this;',
1210 ' };',
1211 ' });',
1212 ' this.T = null;',
1213 ' $mod.$main = function () {',
1214 ' $mod.T = $mod.TObject.$create("Create",[0]);',
1215 ' };',
1216 '});',
1217 '']);
1218 CheckDiff('TestWPO_ConstructorDefaultValueConst',ExpectedSrc,ActualSrc);
1219 end;
1220
1221 procedure TTestOptimizations.TestWPO_RTTI_PublishedField;
1222 var
1223 ActualSrc, ExpectedSrc: String;
1224 begin
1225 Converter.Options:=Converter.Options-[coNoTypeInfo];
1226 StartProgram(true);
1227 Add('type');
1228 Add(' TArrA = array of char;');
1229 Add(' TArrB = array of string;');
1230 Add(' TObject = class');
1231 Add(' public');
1232 Add(' PublicA: TArrA;');
1233 Add(' published');
1234 Add(' PublishedB: TArrB;');
1235 Add(' end;');
1236 Add('var');
1237 Add(' C: TObject;');
1238 Add('begin');
1239 Add(' C.PublicA:=nil;');
1240 ConvertProgram;
1241 ActualSrc:=ConvertJSModuleToString(JSModule);
1242 ExpectedSrc:=LinesToStr([
1243 'rtl.module("program", ["system"], function () {',
1244 ' var $mod = this;',
1245 ' $mod.$rtti.$DynArray("TArrB", {',
1246 ' eltype: rtl.string',
1247 ' });',
1248 ' rtl.createClass($mod, "TObject", null, function () {',
1249 ' this.$init = function () {',
1250 ' this.PublicA = [];',
1251 ' this.PublishedB = [];',
1252 ' };',
1253 ' this.$final = function () {',
1254 ' this.PublicA = undefined;',
1255 ' this.PublishedB = undefined;',
1256 ' };',
1257 ' var $r = this.$rtti;',
1258 ' $r.addField("PublishedB", $mod.$rtti["TArrB"]);',
1259 ' });',
1260 ' this.C = null;',
1261 ' $mod.$main = function () {',
1262 ' $mod.C.PublicA = [];',
1263 ' };',
1264 '});',
1265 '']);
1266 CheckDiff('TestWPO_RTTI_PublishedField',ExpectedSrc,ActualSrc);
1267 end;
1268
1269 procedure TTestOptimizations.TestWPO_RTTI_TypeInfo;
1270 var
1271 ActualSrc, ExpectedSrc: String;
1272 begin
1273 Converter.Options:=Converter.Options-[coNoTypeInfo];
1274 StartProgram(true);
1275 Add('type');
1276 Add(' TArrA = array of char;');
1277 Add(' TArrB = array of string;');
1278 Add('var');
1279 Add(' A: TArrA;');
1280 Add(' B: TArrB;');
1281 Add(' p: pointer;');
1282 Add('begin');
1283 Add(' A:=nil;');
1284 Add(' p:=typeinfo(B);');
1285 ConvertProgram;
1286 ActualSrc:=ConvertJSModuleToString(JSModule);
1287 ExpectedSrc:=LinesToStr([
1288 'rtl.module("program", ["system"], function () {',
1289 ' var $mod = this;',
1290 ' $mod.$rtti.$DynArray("TArrB", {',
1291 ' eltype: rtl.string',
1292 ' });',
1293 ' this.A = [];',
1294 ' this.B = [];',
1295 ' this.p = null;',
1296 ' $mod.$main = function () {',
1297 ' $mod.A = [];',
1298 ' $mod.p = $mod.$rtti["TArrB"];',
1299 ' };',
1300 '});',
1301 '']);
1302 CheckDiff('TestWPO_RTTI_TypeInfo',ExpectedSrc,ActualSrc);
1303 end;
1304
1305 Initialization
1306 RegisterTests([TTestOptimizations]);
1307 end.
1308
1309