paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 13:31:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

--- Merging r35565 into '.':

Browse Source 
U    packages/fcl-json/tests/testjsonrtti.pp
U    packages/fcl-json/src/fpjsonrtti.pp
--- Recording mergeinfo for merge of r35565 into '.':
 U   .
--- Merging r35571 into '.':
U    packages/fcl-passrc/src/pparser.pp
U    packages/fcl-passrc/tests/testpassrc.lpi
A    packages/fcl-passrc/tests/tcgenerics.pp
U    packages/fcl-passrc/tests/tctypeparser.pas
U    packages/fcl-passrc/tests/testpassrc.lpr
--- Recording mergeinfo for merge of r35571 into '.':
 G   .
--- Merging r35574 into '.':
U    packages/pastojs/fpmake.pp
--- Recording mergeinfo for merge of r35574 into '.':
 G   .
--- Merging r35576 into '.':
U    packages/fcl-js/src/jsscanner.pp
--- Recording mergeinfo for merge of r35576 into '.':
 G   .
--- Merging r35577 into '.':
U    packages/fcl-js/tests/tcwriter.pp
U    packages/fcl-js/src/jswriter.pp
--- Recording mergeinfo for merge of r35577 into '.':
 G   .
--- Merging r35578 into '.':
U    packages/fcl-passrc/src/pastree.pp
--- Recording mergeinfo for merge of r35578 into '.':
 G   .
--- Merging r35579 into '.':
U    packages/fcl-passrc/src/pscanner.pp
--- Recording mergeinfo for merge of r35579 into '.':
 G   .
--- Merging r35580 into '.':
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35580 into '.':
 G   .
--- Merging r35581 into '.':
U    packages/fcl-passrc/src/pasresolver.pp
--- Recording mergeinfo for merge of r35581 into '.':
 G   .
--- Merging r35582 into '.':
U    packages/fcl-passrc/tests/tcresolver.pas
--- Recording mergeinfo for merge of r35582 into '.':
 G   .
--- Merging r35583 into '.':
U    packages/pastojs/tests/tcmodules.pas
--- Recording mergeinfo for merge of r35583 into '.':
 G   .
--- Merging r35584 into '.':
U    packages/fcl-passrc/tests/tcbaseparser.pas
--- Recording mergeinfo for merge of r35584 into '.':
 G   .
--- Merging r35585 into '.':
U    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35585 into '.':
 G   .
--- Merging r35586 into '.':
G    packages/fcl-passrc/tests/testpassrc.lpr
A    packages/fcl-passrc/tests/tcuseanalyzer.pas
G    packages/fcl-passrc/tests/testpassrc.lpi
A    packages/fcl-passrc/src/pasuseanalyzer.pas
--- Recording mergeinfo for merge of r35586 into '.':
 G   .
--- Merging r35587 into '.':
U    packages/pastojs/tests/testpas2js.lpi
--- Recording mergeinfo for merge of r35587 into '.':
 G   .
--- Merging r35588 into '.':
G    packages/fcl-passrc/src/pscanner.pp
--- Recording mergeinfo for merge of r35588 into '.':
 G   .
--- Merging r35591 into '.':
U    packages/fcl-passrc/tests/tcexprparser.pas
U    packages/fcl-passrc/tests/tcgenerics.pp
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35591 into '.':
 G   .
--- Merging r35593 into '.':
U    packages/fcl-passrc/tests/tcstatements.pas
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35593 into '.':
 G   .
--- Merging r35597 into '.':
U    packages/fcl-passrc/tests/tcprocfunc.pas
G    packages/fcl-passrc/src/pastree.pp
--- Recording mergeinfo for merge of r35597 into '.':
 G   .
--- Merging r35612 into '.':
G    packages/fcl-passrc/tests/tcgenerics.pp
G    packages/fcl-passrc/src/pparser.pp
G    packages/fcl-passrc/src/pastree.pp
--- Recording mergeinfo for merge of r35612 into '.':
 G   .
--- Merging r35613 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/src/pscanner.pp
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35613 into '.':
 G   .
--- Merging r35614 into '.':
U    packages/fcl-passrc/tests/tcuseanalyzer.pas
U    packages/fcl-passrc/src/pasuseanalyzer.pas
--- Recording mergeinfo for merge of r35614 into '.':
 G   .
--- Merging r35615 into '.':
G    packages/pastojs/src/fppas2js.pp
U    packages/pastojs/tests/testpas2js.pp
G    packages/pastojs/tests/tcmodules.pas
A    packages/pastojs/tests/tcoptimizations.pas
G    packages/pastojs/tests/testpas2js.lpi
--- Recording mergeinfo for merge of r35615 into '.':
 G   .
--- Merging r35616 into '.':
G    packages/fcl-passrc/tests/tcgenerics.pp
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35616 into '.':
 G   .
--- Merging r35617 into '.':
G    packages/fcl-passrc/tests/tcgenerics.pp
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35617 into '.':
 G   .
--- Merging r35621 into '.':
G    packages/fcl-passrc/src/pscanner.pp
--- Recording mergeinfo for merge of r35621 into '.':
 G   .
--- Merging r35623 into '.':
U    packages/fcl-web/src/base/fpweb.pp
--- Recording mergeinfo for merge of r35623 into '.':
 G   .
--- Merging r35625 into '.':
U    packages/fcl-passrc/tests/tcscanner.pas
G    packages/fcl-passrc/src/pscanner.pp
--- Recording mergeinfo for merge of r35625 into '.':
 G   .
--- Merging r35631 into '.':
U    utils/pas2js/dist/rtl.js
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35631 into '.':
 G   .
--- Merging r35633 into '.':
G    packages/fcl-js/src/jswriter.pp
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pastree.pp
G    packages/fcl-passrc/src/pasresolver.pp
U    packages/pastojs/tests/tcconverter.pp
G    packages/pastojs/tests/tcmodules.pas
U    packages/pastojs/tests/tcoptimizations.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35633 into '.':
 G   .
--- Merging r35635 into '.':
G    packages/fcl-passrc/tests/testpassrc.lpi
U    packages/fcl-passrc/tests/tcclasstype.pas
G    packages/fcl-passrc/src/pastree.pp
G    packages/fcl-passrc/src/pscanner.pp
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35635 into '.':
 G   .
--- Merging r35636 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/tests/tcclasstype.pas
G    packages/fcl-passrc/src/pastree.pp
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35636 into '.':
 G   .
--- Merging r35637 into '.':
G    packages/fcl-passrc/tests/tcclasstype.pas
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35637 into '.':
 G   .
--- Merging r35638 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35638 into '.':
 G   .
--- Merging r35639 into '.':
G    packages/fcl-passrc/src/pparser.pp
U    packages/fcl-passrc/tests/tcvarparser.pas
G    packages/fcl-passrc/tests/tcclasstype.pas
G    packages/fcl-passrc/tests/tcresolver.pas
--- Recording mergeinfo for merge of r35639 into '.':
 G   .
--- Merging r35640 into '.':
G    packages/fcl-js/src/jswriter.pp
--- Recording mergeinfo for merge of r35640 into '.':
 G   .
--- Merging r35641 into '.':
G    packages/fcl-passrc/tests/tcstatements.pas
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35641 into '.':
 G   .
--- Merging r35642 into '.':
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/tests/tcresolver.pas
--- Recording mergeinfo for merge of r35642 into '.':
 G   .
--- Merging r35643 into '.':
G    packages/pastojs/src/fppas2js.pp
G    packages/pastojs/tests/tcmodules.pas
--- Recording mergeinfo for merge of r35643 into '.':
 G   .
--- Merging r35644 into '.':
U    packages/fcl-json/src/jsonconf.pp
--- Recording mergeinfo for merge of r35644 into '.':
 G   .
--- Merging r35648 into '.':
U    packages/fcl-passrc/fpmake.pp
--- Recording mergeinfo for merge of r35648 into '.':
 G   .
--- Merging r35651 into '.':
G    packages/fcl-js/src/jswriter.pp
--- Recording mergeinfo for merge of r35651 into '.':
 G   .
--- Merging r35652 into '.':
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35652 into '.':
 G   .
--- Merging r35653 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35653 into '.':
 G   .
--- Merging r35667 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/tests/tcuseanalyzer.pas
G    packages/fcl-passrc/src/pastree.pp
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/src/pasuseanalyzer.pas
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35667 into '.':
 G   .
--- Merging r35668 into '.':
G    packages/pastojs/tests/tcconverter.pp
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/tests/tcoptimizations.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35668 into '.':
 G   .
--- Merging r35680 into '.':
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35680 into '.':
 G   .
--- Merging r35681 into '.':
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/tests/tcresolver.pas
--- Recording mergeinfo for merge of r35681 into '.':
 G   .
--- Merging r35682 into '.':
G    packages/fcl-passrc/src/pasuseanalyzer.pas
G    packages/fcl-passrc/tests/tcuseanalyzer.pas
--- Recording mergeinfo for merge of r35682 into '.':
 G   .
--- Merging r35683 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35683 into '.':
 G   .
--- Merging r35691 into '.':
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35691 into '.':
 G   .
--- Merging r35692 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pasresolver.pp
--- Recording mergeinfo for merge of r35692 into '.':
 G   .
--- Merging r35693 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35693 into '.':
 G   .
--- Merging r35694 into '.':
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35694 into '.':
 G   .
--- Merging r35695 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pasresolver.pp
--- Recording mergeinfo for merge of r35695 into '.':
 G   .
--- Merging r35696 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35696 into '.':
 G   .
--- Merging r35697 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/tests/tcuseanalyzer.pas
G    packages/fcl-passrc/src/pasuseanalyzer.pas
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35697 into '.':
 G   .
--- Merging r35702 into '.':
G    packages/fcl-passrc/tests/tcbaseparser.pas
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pasresolver.pp
--- Recording mergeinfo for merge of r35702 into '.':
 G   .
--- Merging r35703 into '.':
G    packages/fcl-passrc/tests/tcuseanalyzer.pas
G    packages/fcl-passrc/src/pasuseanalyzer.pas
--- Recording mergeinfo for merge of r35703 into '.':
 G   .
--- Merging r35704 into '.':
G    packages/pastojs/src/fppas2js.pp
G    packages/pastojs/tests/tcmodules.pas
--- Recording mergeinfo for merge of r35704 into '.':
 G   .
--- Merging r35705 into '.':
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35705 into '.':
 G   .
--- Merging r35706 into '.':
G    packages/pastojs/tests/tcmodules.pas
--- Recording mergeinfo for merge of r35706 into '.':
 G   .
--- Merging r35708 into '.':
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/tests/tcuseanalyzer.pas
--- Recording mergeinfo for merge of r35708 into '.':
 G   .
--- Merging r35709 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pasresolver.pp
--- Recording mergeinfo for merge of r35709 into '.':
 G   .
--- Merging r35710 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pasresolver.pp
--- Recording mergeinfo for merge of r35710 into '.':
 G   .
--- Merging r35711 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35711 into '.':
 G   .
--- Merging r35713 into '.':
G    packages/fcl-passrc/src/pasresolver.pp
--- Recording mergeinfo for merge of r35713 into '.':
 G   .
--- Merging r35714 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35714 into '.':
 G   .
--- Merging r35715 into '.':
G    packages/fcl-passrc/src/pastree.pp
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/src/pasuseanalyzer.pas
--- Recording mergeinfo for merge of r35715 into '.':
 G   .
--- Merging r35716 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35716 into '.':
 G   .
--- Merging r35718 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
G    packages/fcl-passrc/src/pasresolver.pp
--- Recording mergeinfo for merge of r35718 into '.':
 G   .
--- Merging r35719 into '.':
G    packages/pastojs/src/fppas2js.pp
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/tests/tcuseanalyzer.pas
G    packages/fcl-passrc/src/pasresolver.pp
--- Recording mergeinfo for merge of r35719 into '.':
 G   .
--- Merging r35720 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/tests/tcuseanalyzer.pas
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/src/pasuseanalyzer.pas
--- Recording mergeinfo for merge of r35720 into '.':
 G   .
--- Merging r35728 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pastree.pp
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/src/pscanner.pp
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r35728 into '.':
 G   .
--- Merging r35729 into '.':
G    packages/pastojs/src/fppas2js.pp
G    packages/pastojs/tests/tcmodules.pas
--- Recording mergeinfo for merge of r35729 into '.':
 G   .
--- Merging r35731 into '.':
G    packages/fcl-passrc/src/pasuseanalyzer.pas
G    packages/fcl-passrc/src/pparser.pp
G    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/tests/tcuseanalyzer.pas
--- Recording mergeinfo for merge of r35731 into '.':
 G   .
--- Merging r35732 into '.':
G    packages/pastojs/src/fppas2js.pp
G    packages/pastojs/tests/tcmodules.pas
--- Recording mergeinfo for merge of r35732 into '.':
 G   .
--- Merging r35735 into '.':
G    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/src/pasresolver.pp
--- Recording mergeinfo for merge of r35735 into '.':
 G   .
--- Merging r35736 into '.':
G    packages/pastojs/src/fppas2js.pp
G    packages/pastojs/tests/tcmodules.pas
--- Recording mergeinfo for merge of r35736 into '.':
 G   .
--- Merging r35737 into '.':
G    packages/fcl-passrc/tests/tcuseanalyzer.pas
--- Recording mergeinfo for merge of r35737 into '.':
 G   .
--- Merging r35738 into '.':
G    packages/pastojs/tests/tcmodules.pas
G    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r35738 into '.':
 G   .

# revisions: 35565,35571,35574,35576,35577,35578,35579,35580,35581,35582,35583,35584,35585,35586,35587,35588,35591,35593,35597,35612,35613,35614,35615,35616,35617,35621,35623,35625,35631,35633,35635,35636,35637,35638,35639,35640,35641,35642,35643,35644,35648,35651,35652,35653,35667,35668,35680,35681,35682,35683,35691,35692,35693,35694,35695,35696,35697,35702,35703,35704,35705,35706,35708,35709,35710,35711,35713,35714,35715,35716,35718,35719,35720,35728,35729,35731,35732,35735,35736,35737,35738

git-svn-id: branches/fixes_3_0@35986 -
This commit is contained in:
marco 2017-04-27 19:48:42 +00:00
parent b300edd432
commit a4445c0e9f
35 changed files with 17128 additions and 3342 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -2532,6 +2532,7 @@ packages/fcl-passrc/src/pasresolver.pp svneol=native#text/plain
packages/fcl-passrc/src/passrcutil.pp svneol=native#text/plain
packages/fcl-passrc/src/pastounittest.pp svneol=native#text/plain
packages/fcl-passrc/src/pastree.pp svneol=native#text/plain
packages/fcl-passrc/src/pasuseanalyzer.pas svneol=native#text/plain
packages/fcl-passrc/src/paswrite.pp svneol=native#text/plain
packages/fcl-passrc/src/pparser.pp svneol=native#text/plain
packages/fcl-passrc/src/pscanner.pp svneol=native#text/plain
@ -2539,6 +2540,7 @@ packages/fcl-passrc/src/readme.txt svneol=native#text/plain
packages/fcl-passrc/tests/tcbaseparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcclasstype.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcexprparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcgenerics.pp svneol=native#text/plain
packages/fcl-passrc/tests/tcmoduleparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tconstparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcpassrcutil.pas svneol=native#text/plain
@ -2547,6 +2549,7 @@ packages/fcl-passrc/tests/tcresolver.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcscanner.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcstatements.pas svneol=native#text/plain
packages/fcl-passrc/tests/tctypeparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcuseanalyzer.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcvarparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/testpassrc.lpi svneol=native#text/plain
packages/fcl-passrc/tests/testpassrc.lpr svneol=native#text/plain
@ -6524,6 +6527,7 @@ packages/pastojs/fpmake.pp svneol=native#text/plain
packages/pastojs/src/fppas2js.pp svneol=native#text/plain
packages/pastojs/tests/tcconverter.pp svneol=native#text/plain
packages/pastojs/tests/tcmodules.pas svneol=native#text/plain
packages/pastojs/tests/tcoptimizations.pas svneol=native#text/plain
packages/pastojs/tests/testpas2js.lpi svneol=native#text/plain
packages/pastojs/tests/testpas2js.pp svneol=native#text/plain
packages/pastojs/todo.txt svneol=native#text/plain

3
packages/fcl-js/src/jsscanner.pp
View File

@ -515,7 +515,10 @@ begin
FCurToken := Result;
exit;
end;
{$Push}
{$R-}
I:=Succ(I);
{$Pop}
end
end;

159
packages/fcl-js/src/jswriter.pp
View File

@ -127,7 +127,7 @@ Type
// one per type of statement
Procedure WriteValue(V : TJSValue); virtual;
Procedure WriteRegularExpressionLiteral(El: TJSRegularExpressionLiteral);
Procedure WriteVariableStatement(el: TJSVariableStatement);
Procedure WriteVariableStatement(El: TJSVariableStatement);
Procedure WriteEmptyBlockStatement(El: TJSEmptyBlockStatement); virtual;
Procedure WriteEmptyStatement(El: TJSEmptyStatement);virtual;
Procedure WriteLiteral(El: TJSLiteral);virtual;
@ -157,6 +157,8 @@ Type
Procedure WriteFuncDef(FD: TJSFuncDef);virtual;
Procedure WritePrimaryExpression(El: TJSPrimaryExpression);virtual;
Procedure WriteBinary(El: TJSBinary);virtual;
Function IsEmptyStatement(El: TJSElement): boolean;
Function HasLineEnding(El: TJSElement): boolean;
Public
Function EscapeString(const S: TJSString; Quote: TJSEscapeQuote = jseqDouble): TJSString;
Constructor Create(AWriter : TTextWriter);
@ -584,6 +586,7 @@ procedure TJSWriter.WriteFuncDef(FD: TJSFuncDef);
Var
C : Boolean;
I : Integer;
A: TJSElement;
begin
C:=(woCompact in Options);
@ -609,10 +612,11 @@ begin
FSkipCurlyBrackets:=True;
//writeln('TJSWriter.WriteFuncDef '+FD.Body.ClassName);
WriteJS(FD.Body);
If (Assigned(FD.Body.A))
and (not (FD.Body.A is TJSStatementList))
and (not (FD.Body.A is TJSSourceElements))
and (not (FD.Body.A is TJSEmptyBlockStatement))
A:=FD.Body.A;
If (Assigned(A))
and (not (A is TJSStatementList))
and (not (A is TJSSourceElements))
and (not (A is TJSEmptyBlockStatement))
then
if C then
Write('; ')
@ -780,7 +784,8 @@ begin
if (MExpr is TJSPrimaryExpression)
or (MExpr is TJSDotMemberExpression)
or (MExpr is TJSBracketMemberExpression)
or (MExpr is TJSCallExpression)
// Note: new requires brackets in this case: new (a())()
or ((MExpr is TJSCallExpression) and not (El is TJSNewMemberExpression))
or (MExpr is TJSLiteral) then
WriteJS(MExpr)
else
@ -861,7 +866,7 @@ begin
Indent;
if not C then writeln('');
end;
if Assigned(El.A) and (El.A.ClassType<>TJSEmptyBlockStatement) then
if not IsEmptyStatement(El.A) then
begin
WriteJS(El.A);
LastEl:=El.A;
@ -880,6 +885,12 @@ begin
end;
if (not C) and not (LastEl is TJSStatementList) then
writeln(';');
end
else if Assigned(El.B) then
begin
WriteJS(El.B);
if (not C) and not (El.B is TJSStatementList) then
writeln(';');
end;
if B then
begin
@ -920,6 +931,9 @@ Var
S : AnsiString;
AllowCompact, WithBrackets: Boolean;
begin
{$IFDEF VerboseJSWriter}
System.writeln('TJSWriter.WriteBinary SkipRoundBrackets=',FSkipRoundBrackets);
{$ENDIF}
WithBrackets:=not FSkipRoundBrackets;
if WithBrackets then
Write('(');
@ -939,6 +953,25 @@ begin
Write(')');
end;
function TJSWriter.IsEmptyStatement(El: TJSElement): boolean;
begin
if (El=nil) then
exit(true);
if (El.ClassType=TJSEmptyStatement) and not (woEmptyStatementAsComment in Options) then
exit(true);
Result:=false;
end;
function TJSWriter.HasLineEnding(El: TJSElement): boolean;
begin
if El<>nil then
begin
if (El.ClassType=TJSStatementList) or (El.ClassType=TJSSourceElements) then
exit(true);
end;
Result:=false;
end;
procedure TJSWriter.WriteConditionalExpression(El: TJSConditionalExpression);
begin
@ -981,24 +1014,51 @@ end;
procedure TJSWriter.WriteIfStatement(El: TJSIfStatement);
var
HasBTrue, C, HasBFalse, BTrueNeedBrackets: Boolean;
begin
C:=woCompact in Options;
Write('if (');
FSkipRoundBrackets:=true;
WriteJS(El.Cond);
FSkipRoundBrackets:=false;
Write(')');
If Not (woCompact in Options) then
If Not C then
Write(' ');
if (El.BTrue<>nil) and (not (El.BTrue is TJSEmptyStatement)) then
HasBTrue:=not IsEmptyStatement(El.BTrue);
HasBFalse:=not IsEmptyStatement(El.BFalse);
if HasBTrue then
begin
// Note: the 'else' needs {} in front
BTrueNeedBrackets:=HasBFalse and not (El.BTrue is TJSStatementList)
and not (El.BTrue is TJSEmptyBlockStatement);
if BTrueNeedBrackets then
if C then
Write('{')
else
begin
Writeln('{');
Indent;
end;
WriteJS(El.BTrue);
if BTrueNeedBrackets then
if C then
Write('}')
else
begin
Undent;
Writeln('}');
end;
end;
if Assigned(El.BFalse) then
if HasBFalse then
begin
if (El.BTrue=nil) or (El.BTrue is TJSEmptyStatement) then
Writeln('{}')
else if not (El.BTrue is TJSStatementList) then
Writeln('')
if not HasBTrue then
begin
if C then
Write('{}')
else
Writeln('{}');
end
else
Write(' ');
Write('else ');
@ -1117,28 +1177,37 @@ begin
WriteJS(EC.Expr);
FSkipRoundBrackets:=false;
end;
If C then
Write(': ')
else
Writeln(':');
if Assigned(EC.Body) then
begin
FSkipCurlyBrackets:=true;
If C then
Write(': ')
else
Writeln(':');
Indent;
WriteJS(EC.Body);
Undent;
if Not ((EC.Body is TJSStatementList) or (EC.Body is TJSEmptyBlockStatement)) then
if (EC.Body is TJSStatementList) or (EC.Body is TJSEmptyBlockStatement) then
begin
if C then
Write('; ')
begin
if I<El.Cases.Count-1 then
Write(' ');
end
else
Writeln(';');
Writeln('');
end
else if C then
Write('; ')
else
Writeln(';');
end
else
begin
if C then
Write('; ')
Write(': ')
else
Writeln(';');
Writeln(':');
end;
end;
Write('}');
@ -1213,11 +1282,15 @@ Var
begin
C:=woCompact in Options;
Write('try {');
if Not C then writeln('');
FSkipCurlyBrackets:=True;
Indent;
WriteJS(El.Block);
Undent;
if not IsEmptyStatement(El.Block) then
begin
if Not C then writeln('');
FSkipCurlyBrackets:=True;
Indent;
WriteJS(El.Block);
if (Not C) and (not (El.Block is TJSStatementList)) then writeln('');
Undent;
end;
Write('}');
If (El is TJSTryCatchFinallyStatement) or (El is TJSTryCatchStatement) then
begin
@ -1227,10 +1300,14 @@ begin
Write(' {')
else
Writeln(' {');
FSkipCurlyBrackets:=True;
Indent;
WriteJS(El.BCatch);
Undent;
if not IsEmptyStatement(El.BCatch) then
begin
FSkipCurlyBrackets:=True;
Indent;
WriteJS(El.BCatch);
Undent;
if (Not C) and (not (El.BCatch is TJSStatementList)) then writeln('');
end;
Write('}');
end;
If (El is TJSTryCatchFinallyStatement) or (El is TJSTryFinallyStatement) then
@ -1239,10 +1316,14 @@ begin
Write(' finally {')
else
Writeln(' finally {');
Indent;
FSkipCurlyBrackets:=True;
WriteJS(El.BFinally);
Undent;
if not IsEmptyStatement(El.BFinally) then
begin
Indent;
FSkipCurlyBrackets:=True;
WriteJS(El.BFinally);
Undent;
if (Not C) and (not (El.BFinally is TJSStatementList)) then writeln('');
end;
Write('}');
end;
end;
@ -1251,7 +1332,7 @@ procedure TJSWriter.WriteFunctionBody(El: TJSFunctionBody);
begin
//writeln('TJSWriter.WriteFunctionBody '+El.A.ClassName+' FSkipBrackets='+BoolToStr(FSkipCurlyBrackets,'true','false'));
if Assigned(El.A) and (not (El.A is TJSEmptyBlockStatement)) then
if not IsEmptyStatement(El.A) then
WriteJS(El.A);
end;
@ -1295,11 +1376,11 @@ begin
WriteElements(El.Statements);
end;
procedure TJSWriter.WriteVariableStatement(el: TJSVariableStatement);
procedure TJSWriter.WriteVariableStatement(El: TJSVariableStatement);
begin
Write('var ');
WriteJS(EL.A);
WriteJS(El.A);
end;
procedure TJSWriter.WriteJS(El: TJSElement);

179
packages/fcl-js/tests/tcwriter.pp
View File

@ -84,6 +84,8 @@ type
Public
Procedure TestAssignment(Const Msg : String; AClass : TJSAssignStatementClass; Result : String;ACompact : Boolean);
Function CreateAssignment(AClass : TJSAssignStatementClass) : TJSAssignStatement;
Function CreateStatementListOneElement : TJSStatementList;
Function CreateStatementListTwoElement2 : TJSStatementList;
published
Procedure TestEmptyStatement;
Procedure TestEmptyStatementComment;
@ -130,6 +132,7 @@ type
Procedure TestAssignmentStatementBinaryAndCompact;
Procedure TestForStatementEmpty;
Procedure TestForStatementFull;
Procedure TestForStatementFull1;
Procedure TestForStatementCompact;
Procedure TestForInStatement;
Procedure TestWhileStatement;
@ -152,6 +155,7 @@ type
Procedure TestStatementListOneStatementCompact;
Procedure TestStatementListTwoStatements;
Procedure TestStatementListTwoStatementsCompact;
Procedure TestStatementListFor;
Procedure TestEmptyFunctionDef;
Procedure TestEmptyFunctionDefCompact;
Procedure TestFunctionDefParams;
@ -628,7 +632,7 @@ begin
U.Args:=TJSArguments.Create(0,0);
U.Args.Elements.AddElement;
U.Args.Elements[0].Expr:=CreateLiteral(123);
AssertWrite('member b of object a (a[b])','new a('+slinebreak+'123'+sLineBreak+')',U);
AssertWrite('member b of object a (a[b])','new a(123)',U);
end;
Procedure TTestExpressionWriter.TestNewMemberCompact;
@ -666,7 +670,8 @@ begin
U.Args:=TJSArguments.Create(0,0);
U.Args.Elements.AddElement;
U.Args.Elements[0].Expr:=CreateLiteral(123);
AssertWrite('call a(123)','a('+slinebreak+'123'+sLineBreak+')',U);
AssertWrite('call a(123)',
'a(123)',U);
end;
Procedure TTestExpressionWriter.TestCallCompact;
@ -696,7 +701,7 @@ begin
U.Args.Elements[0].Expr:=CreateLiteral(123);
U.Args.Elements.AddElement;
U.Args.Elements[1].Expr:=CreateLiteral(456);
AssertWrite('call a(123,456)','a(123, 456)',U);
AssertWrite('call a(123,456)','a(123,456)',U);
end;
@ -767,6 +772,19 @@ begin
Result.Expr:=CreateIdent('b');
end;
function TTestStatementWriter.CreateStatementListOneElement: TJSStatementList;
begin
Result:=TJSStatementList.Create(0,0);
Result.A:=CreateAssignment(nil);
end;
function TTestStatementWriter.CreateStatementListTwoElement2: TJSStatementList;
begin
Result:=TJSStatementList.Create(0,0);
Result.A:=CreateAssignment(nil);
Result.B:=CreateAssignment(nil);
end;
Procedure TTestStatementWriter.TestEmptyStatement;
begin
@ -1120,7 +1138,6 @@ end;
Procedure TTestStatementWriter.TestForStatementFull;
Var
S : TJSForStatement;
UPP : TJSUnaryPostPlusPlusExpression;
@ -1141,7 +1158,35 @@ begin
S.Incr:=UPP;
S.Cond:=CL;
S.Body:=TJSEmptyBlockStatement.Create(0,0);
AssertWrite('for i:=0 to 9','for (i = 0; (i < 10); i++) {'+sLineBreak+'}',S);
AssertWrite('for i:=0 to 9','for (i = 0; i < 10; i++) {'+sLineBreak+'}',S);
end;
procedure TTestStatementWriter.TestForStatementFull1;
Var
S : TJSForStatement;
UPP : TJSUnaryPostPlusPlusExpression;
CL : TJSRelationalExpressionLT;
sa : TJSSimpleAssignStatement;
begin
SA:=TJSSimpleAssignStatement.Create(0,0);
SA.LHS:=CreateIdent('i');
SA.Expr:=CreateLiteral(0);
UPP:=TJSUnaryPostPlusPlusExpression.Create(0,0);
UPP.A:=CreateIdent('i');
CL:=TJSRelationalExpressionLT.Create(0,0);
CL.A:=CreateIdent('i');
CL.B:=CreateLiteral(10);
S:=TJSForStatement.Create(0,0);
S.Init:=SA;
S.Incr:=UPP;
S.Cond:=CL;
S.Body:=CreateStatementListOneElement;
AssertWrite('for i:=0 to 9',
'for (i = 0; i < 10; i++) {'+sLineBreak
+'a = b;'+sLineBreak
+'}',S);
end;
Procedure TTestStatementWriter.TestForStatementCompact;
@ -1166,7 +1211,7 @@ begin
S.Cond:=CL;
S.Body:=TJSEmptyBlockStatement.Create(0,0);
Writer.Options:=[woCompact,woUseUTF8];
AssertWrite('for i:=0 to 9','for (i=0; (i<10); i++) {}',S);
AssertWrite('for i:=0 to 9','for (i=0; i<10; i++) {}',S);
end;
Procedure TTestStatementWriter.TestForInStatement;
@ -1288,7 +1333,7 @@ begin
C:=S.Cases.AddCase;
C.Body:=TJSEmptyBlockStatement.Create(0,0);;
C.Expr:=CreateIdent('d');
AssertWrite('switch ','switch (a) {case c: {}case d: {}}',S);
AssertWrite('switch ','switch (a) {case c: {} case d: {}}',S);
end;
Procedure TTestStatementWriter.TestSwitchStatementTwoElementsDefault;
@ -1327,7 +1372,7 @@ begin
C:=S.Cases.AddCase;
C.Body:=TJSEmptyBlockStatement.Create(0,0);;
S.TheDefault:=C;
AssertWrite('switch ','switch (a) {case c: {}case d: {}default: {}}',S);
AssertWrite('switch ','switch (a) {case c: {} case d: {} default: {}}',S);
end;
Procedure TTestStatementWriter.TestSwitchStatementTwoElementsOneEmpty;
@ -1345,7 +1390,16 @@ begin
C:=S.Cases.AddCase;
C.Body:=TJSEmptyBlockStatement.Create(0,0);;
S.TheDefault:=C;
AssertWrite('switch ','switch (a) {'+sLineBreak+'case c:'+sLineBreak+'case d:'+sLineBreak+'{'+sLineBreak+'}'+sLineBreak+'default:'+sLineBreak+'{'+sLineBreak+'}'+sLineBreak+'}',S);
AssertWrite('switch ',
'switch (a) {'+sLineBreak
+'case c:'+sLineBreak
+'case d:'+sLineBreak
+'{'+sLineBreak
+'}'+sLineBreak
+'default:'+sLineBreak
+'{'+sLineBreak
+'}'+sLineBreak
+'}',S);
end;
Procedure TTestStatementWriter.TestSwitchStatementTwoElementsOneEmptyCompact;
@ -1364,7 +1418,7 @@ begin
C:=S.Cases.AddCase;
C.Body:=TJSEmptyBlockStatement.Create(0,0);;
S.TheDefault:=C;
AssertWrite('switch ','switch (a) {case c: case d: {}default: {}}',S);
AssertWrite('switch ','switch (a) {case c: case d: {} default: {}}',S);
end;
Procedure TTestStatementWriter.TestIfThen;
@ -1389,7 +1443,10 @@ begin
S.Cond:=CreateIdent('a');
S.btrue:=TJSEmptyBlockStatement.Create(0,0);
S.bfalse:=TJSEmptyBlockStatement.Create(0,0);
AssertWrite('if then','if (a) {'+sLineBreak+'} else {'+sLineBreak+'}',S);
AssertWrite('if then',
'if (a) {'+sLineBreak
+'} else {'+sLineBreak
+'}',S);
end;
Procedure TTestStatementWriter.TestStatementListEmpty;
@ -1415,12 +1472,14 @@ end;
Procedure TTestStatementWriter.TestStatementListOneStatement;
Var
S : TJSStatementList;
begin
// Writer.Options:=[woCompact,woUseUTF8];
S:=TJSStatementList.Create(0,0);
S.A:=CreateAssignment(nil);
AssertWrite('Statement list','{'+sLineBreak+'a = b;'+sLineBreak+'}',S);
AssertWrite('Statement list',
'{'+sLineBreak
+'a = b;'+sLineBreak
+'}',S);
end;
Procedure TTestStatementWriter.TestStatementListOneStatementCompact;
@ -1444,7 +1503,11 @@ begin
S:=TJSStatementList.Create(0,0);
S.A:=CreateAssignment(nil);
S.B:=CreateAssignment(nil);
AssertWrite('Statement list','{'+sLineBreak+'a = b;'+sLineBreak+'a = b;'+sLineBreak+'}',S);
AssertWrite('Statement list',
'{'+sLineBreak
+'a = b;'+sLineBreak
+'a = b;'+sLineBreak
+'}',S);
end;
Procedure TTestStatementWriter.TestStatementListTwoStatementsCompact;
@ -1459,6 +1522,21 @@ begin
AssertWrite('Statement list','{a=b; a=b}',S);
end;
procedure TTestStatementWriter.TestStatementListFor;
Var
S : TJSStatementList;
begin
// Writer.Options:=[woCompact,woUseUTF8];
S:=TJSStatementList.Create(0,0);
S.A:=TJSForStatement.Create(0,0);
TJSForStatement(S.A).Body:=TJSEmptyBlockStatement.Create(0,0);
AssertWrite('Statement list',
'{'+sLineBreak
+'for (; ; ) {'+sLineBreak
+'};'+sLineBreak
+'}',S);
end;
Procedure TTestStatementWriter.TestEmptyFunctionDef;
Var
@ -1468,7 +1546,9 @@ begin
FD:=TJSFunctionDeclarationStatement.Create(0,0);
FD.AFunction:=TJSFuncDef.Create;
FD.AFunction.Name:='a';
AssertWrite('Empty function','function a() {'+sLineBreak+'}',FD);
AssertWrite('Empty function',
'function a() {'+sLineBreak
+'}',FD);
end;
Procedure TTestStatementWriter.TestEmptyFunctionDefCompact;
@ -1497,7 +1577,9 @@ begin
FD.AFunction.Params.Add('c');
FD.AFunction.Params.Add('d');
AssertWrite('Empty function, 3 params','function a(b, c, d) {'+sLineBreak+'}',FD);
AssertWrite('Empty function, 3 params',
'function a(b, c, d) {'+sLineBreak
+'}',FD);
end;
Procedure TTestStatementWriter.TestFunctionDefParamsCompact;
@ -1532,7 +1614,10 @@ begin
R:=TJSReturnStatement.Create(0,0);
R.Expr:=CreateLiteral(0);
FD.AFunction.Body.A:=R;
AssertWrite('1 statement, ','function a() {'+sLineBreak+' return 0;'+sLineBreak+'}',FD);
AssertWrite('1 statement, ',
'function a() {'+sLineBreak
+' return 0;'+sLineBreak
+'}',FD);
end;
Procedure TTestStatementWriter.TestFunctionDefBody1Compact;
@ -1581,7 +1666,11 @@ begin
L.A:=A;
L.B:=R;
FD.AFunction.Body.A:=L;
AssertWrite('Function, 2 statements','function a(b) {'+sLineBreak+' b = (b * 10);'+sLineBreak+' return b;'+sLineBreak+'}',FD);
AssertWrite('Function, 2 statements',
'function a(b) {'+sLineBreak
+' b = b * 10;'+sLineBreak
+' return b;'+sLineBreak
+'}',FD);
end;
Procedure TTestStatementWriter.TestFunctionDefBody2Compact;
@ -1612,7 +1701,7 @@ begin
L.A:=A;
L.B:=R;
FD.AFunction.Body.A:=L;
AssertWrite('Function, 2 statements, compact','function a(b) {b=(b*10); return b}',FD);
AssertWrite('Function, 2 statements, compact','function a(b) {b=b*10; return b}',FD);
end;
Procedure TTestStatementWriter.TestTryCatch;
@ -1637,7 +1726,12 @@ begin
A.LHS:=CreateIdent('b');
A.Expr:=CreateLiteral(1);
T.BCatch:=A;
AssertWrite('Try catch','try {'+sLineBreak+' b = (b * 10)'+sLineBreak+'}'+sLineBreak+'catch (e) {'+sLineBreak+' b = 1'+sLineBreak+'}'+sLineBreak,T);
AssertWrite('Try catch',
'try {'+sLineBreak
+' b = b * 10'+sLineBreak
+'} catch (e) {'+sLineBreak
+' b = 1'+sLineBreak
+'}',T);
end;
Procedure TTestStatementWriter.TestTryCatchCompact;
@ -1662,7 +1756,7 @@ begin
A.LHS:=CreateIdent('b');
A.Expr:=CreateLiteral(1);
T.BCatch:=A;
AssertWrite('Try catch compact','try {b=(b*10)} catch (e) {b=1}',T);
AssertWrite('Try catch compact','try {b=b*10} catch (e) {b=1}',T);
end;
Procedure TTestStatementWriter.TestTryFinally;
@ -1687,7 +1781,12 @@ begin
A.LHS:=CreateIdent('b');
A.Expr:=CreateLiteral(1);
T.BFinally:=A;
AssertWrite('Try finally ','try {'+sLineBreak+' b = (b * 10)'+sLineBreak+'}'+sLineBreak+'finally {'+sLineBreak+' b = 1'+sLineBreak+'}'+sLineBreak,T);
AssertWrite('Try finally ',
'try {'+sLineBreak
+' b = b * 10'+sLineBreak
+'} finally {'+sLineBreak
+' b = 1'+sLineBreak
+'}',T);
end;
Procedure TTestStatementWriter.TestTryFinallyCompact;
@ -1713,7 +1812,7 @@ begin
A.LHS:=CreateIdent('b');
A.Expr:=CreateLiteral(1);
T.BFinally:=A;
AssertWrite('Try finally compact','try {b=(b*10)} finally {b=1}',T);
AssertWrite('Try finally compact','try {b=b*10} finally {b=1}',T);
end;
Procedure TTestStatementWriter.TestTryCatchFinally;
@ -1741,7 +1840,13 @@ begin
A.LHS:=CreateIdent('b');
A.Expr:=CreateLiteral(1);
T.BFinally:=A;
AssertWrite('Try finally ','try {'+sLineBreak+' b = (b * 10)'+sLineBreak+'}'+sLineBreak+'catch (e) {'+sLineBreak+' b = 10'+sLineBreak+'}'+sLineBreak+'finally {'+sLineBreak+' b = 1'+sLineBreak+'}'+sLineBreak,T);
AssertWrite('Try finally ',
'try {'+sLineBreak
+' b = b * 10'+sLineBreak
+'} catch (e) {'+sLineBreak
+' b = 10'+sLineBreak
+'} finally {'+sLineBreak
+' b = 1'+sLineBreak+'}',T);
end;
Procedure TTestStatementWriter.TestTryCatchFinallyCompact;
@ -1770,7 +1875,7 @@ begin
A.LHS:=CreateIdent('b');
A.Expr:=CreateLiteral(1);
T.BFinally:=A;
AssertWrite('Try finally ','try {b=(b*10)} catch (e) {b=10} finally {b=1}',T);
AssertWrite('Try finally ','try {b=b*10} catch (e) {b=10} finally {b=1}',T);
end;
Procedure TTestStatementWriter.TestWith;
@ -1791,7 +1896,7 @@ begin
M.B:=CreateLiteral(10);
A.Expr:=M;
T.B:=A;
AssertWrite('With statement ','with (e)'+slineBreak+' b = (b * 10)',T);
AssertWrite('With statement ','with (e)'+slineBreak+' b = b * 10',T);
end;
Procedure TTestStatementWriter.TestWithCompact;
@ -1812,7 +1917,7 @@ begin
M.B:=CreateLiteral(10);
A.Expr:=M;
T.B:=A;
AssertWrite('With statement ','with (e) b=(b*10)',T);
AssertWrite('With statement ','with (e) b=b*10',T);
end;
Procedure TTestStatementWriter.TestSourceElements;
@ -1839,7 +1944,7 @@ begin
M.B:=CreateLiteral(2);
A.Expr:=M;
T.Statements.AddNode.Node:=A;
AssertWrite('Statement lists ','b = (b * 10);'+sLineBreak+'c = (c * 2);'+sLineBreak,T);
AssertWrite('Statement lists ','b = b * 10;'+sLineBreak+'c = c * 2;'+sLineBreak,T);
end;
Procedure TTestStatementWriter.TestSourceElementsCompact;
@ -1866,7 +1971,7 @@ begin
M.B:=CreateLiteral(2);
A.Expr:=M;
T.Statements.AddNode.Node:=A;
AssertWrite('Statement lists compact','b=(b*10); c=(c*2);',T);
AssertWrite('Statement lists compact','b=b*10; c=c*2;',T);
end;
{ ---------------------------------------------------------------------
@ -1931,7 +2036,7 @@ Var
begin
L:=TJSLiteral.Create(0,0,'');
L.Value.AsString:='ab"cd';
AssertWrite('ab"cd','"ab\"cd"',L);
AssertWrite('ab"cd','''ab"cd''',L);
end;
Procedure TTestLiteralWriter.TestStringBackslash;
@ -2027,7 +2132,7 @@ begin
I:=TJSLiteral.Create(0,0);
I.Value.AsNumber:=1;
L.Elements.AddElement.Expr:=I;
AssertWrite('Empty array ','['+sLineBreak+'1'+sLineBreak+']',L);
AssertWrite('Empty array ','[1]',L);
end;
Procedure TTestLiteralWriter.TestArrayOneElementCompact;
@ -2056,7 +2161,7 @@ begin
I:=TJSLiteral.Create(0,0);
I.Value.AsNumber:=1;
L.Elements.AddElement.Expr:=I;
AssertWrite('Empty array ','['+sLineBreak+' 1'+sLineBreak+']',L);
AssertWrite('Empty array ','[1]',L);
end;
Procedure TTestLiteralWriter.TestArrayTwoElements;
@ -2073,7 +2178,7 @@ begin
I:=TJSLiteral.Create(0,0);
I.Value.AsNumber:=2;
L.Elements.AddElement.Expr:=I;
AssertWrite('Empty array ','['+sLineBreak+'1,'+sLineBreak+'2'+sLineBreak+']',L);
AssertWrite('Empty array ','[1, 2]',L);
end;
Procedure TTestLiteralWriter.TestArrayTwoElementsCompact;
@ -2090,7 +2195,7 @@ begin
I:=TJSLiteral.Create(0,0);
I.Value.AsNumber:=2;
L.Elements.AddElement.Expr:=I;
AssertWrite('Empty array ','[1, 2]',L);
AssertWrite('Empty array ','[1,2]',L);
end;
Procedure TTestLiteralWriter.TestArrayTwoElementsCompact2;
@ -2107,7 +2212,7 @@ begin
I:=TJSLiteral.Create(0,0);
I.Value.AsNumber:=2;
L.Elements.AddElement.Expr:=I;
AssertWrite('Empty array ','[1, 2]',L);
AssertWrite('Empty array ','[1,2]',L);
end;
Procedure TTestLiteralWriter.TestArrayThreeElementsCompact;
@ -2127,7 +2232,7 @@ begin
I:=TJSLiteral.Create(0,0);
I.Value.AsNumber:=3;
L.Elements.AddElement.Expr:=I;
AssertWrite('Empty array ','[1, 2, 3]',L);
AssertWrite('Empty array ','[1,2,3]',L);
end;
Procedure TTestLiteralWriter.TestObjectEmpty;
@ -2372,7 +2477,7 @@ Var
S : UnicodeString;
begin
S:=FTextWriter.AsUnicodeString;
AssertEquals(Msg,Result,S);
AssertEquals(Msg,String(Result),String(S));
end;
Procedure TTestJSWriter.AssertWrite(Const Msg, Result: String;

2
packages/fcl-json/src/fpjsonrtti.pp
View File

@ -524,7 +524,7 @@ begin
try
For I:=0 to PIL.Count-1 do
begin
J:=JSON.IndexOfName(Pil.Items[i]^.Name,FCaseInsensitive);
J:=JSON.IndexOfName(Pil.Items[i]^.Name,(jdoCaseInsensitive in Options));
If (J<>-1) then
RestoreProperty(AObject,PIL.Items[i],JSON.Items[J]);
end;

2
packages/fcl-json/src/jsonconf.pp
View File

@ -724,7 +724,7 @@ Var
F : TFileStream;
begin
F:=TFileStream.Create(AFileName,fmopenRead);
F:=TFileStream.Create(AFileName,fmopenRead or fmShareDenyWrite);
try
LoadFromStream(F);
finally

27
packages/fcl-json/tests/testjsonrtti.pp
View File

@ -140,6 +140,8 @@ type
procedure TestEmpty;
procedure TestBoolean;
procedure TestInteger;
procedure TestIntegerCaseInsensitive;
procedure TestIntegerCaseSensitive;
procedure TestString;
procedure TestFloat;
procedure TestFloat2;
@ -318,6 +320,31 @@ begin
AssertEquals('Correct integer value',22,B.IntProp);
end;
procedure TTestJSONDeStreamer.TestIntegerCaseInsensitive;
Var
B : TIntegerComponent;
begin
DS.Options:=DS.Options+[jdoCaseInsensitive];
B:=TIntegerComponent.Create(Nil);
DeStream('{ "intprop" : 22 }',B);
AssertEquals('Correct integer value',22,B.IntProp);
end;
procedure TTestJSONDeStreamer.TestIntegerCaseSensitive;
Var
B : TIntegerComponent;
begin
DS.Options:=DS.Options;
B:=TIntegerComponent.Create(Nil);
B.IntProp:=0;
DeStream('{ "intprop" : 22 }',B);
AssertEquals('Correct integer value not reas',0,B.IntProp);
end;
procedure TTestJSONDeStreamer.TestString;
Var

5
packages/fcl-passrc/fpmake.pp
View File

@ -69,6 +69,11 @@ begin
begin
AddUnit('pastree');
end;
T:=P.Targets.AddUnit('pasuseanalyzer.pas');
with T.Dependencies do
begin
AddUnit('pastree');
end;
{$ifndef ALLPACKAGES}
Run;

4287
packages/fcl-passrc/src/pasresolver.pp
View File

File diff suppressed because it is too large Load Diff

111
packages/fcl-passrc/src/pastree.pp
View File

@ -174,7 +174,7 @@ type
TPasExpr = class(TPasElement)
Kind : TPasExprKind;
OpCode : TExprOpCode;
format1,format2 : TPasExpr;
format1,format2 : TPasExpr; // write, writeln, str
constructor Create(AParent : TPasElement; AKind: TPasExprKind; AOpCode: TExprOpCode); virtual; overload;
destructor Destroy; override;
end;
@ -346,7 +346,7 @@ type
public
InterfaceSection: TInterfaceSection;
ImplementationSection: TImplementationSection;
InitializationSection: TInitializationSection;
InitializationSection: TInitializationSection; // in TPasProgram the begin..end.
FinalizationSection: TFinalizationSection;
PackageName: string;
Filename : String; // the IN filename, only written when not empty.
@ -369,6 +369,7 @@ type
Public
ProgramSection: TProgramSection;
InputFile,OutPutFile : String;
// Note: the begin..end. block is in the InitializationSection
end;
{ TPasLibrary }
@ -506,7 +507,7 @@ type
ElType: TPasType;
end;
{ TPasEnumValue }
{ TPasEnumValue - Parent is TPasEnumType }
TPasEnumValue = class(TPasElement)
public
@ -605,16 +606,23 @@ type
AncestorType: TPasType; // TPasClassType or TPasUnresolvedTypeRef or TPasAliasType or TPasTypeAliasType
HelperForType: TPasType; // TPasClassType or TPasUnresolvedTypeRef
IsForward: Boolean;
IsExternal : Boolean;
IsShortDefinition: Boolean;//class(anchestor); without end
GUIDExpr : TPasExpr;
Members: TFPList; // list of TPasElement
Modifiers: TStringList;
Interfaces : TFPList; // list of TPasElement
GenericTemplateTypes: TFPList; // list of TPasGenericTemplateType
ExternalNameSpace : String;
ExternalName : String;
Procedure SetGenericTemplates(AList : TFPList);
Function FindMember(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
Function FindMemberInAncestors(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
Function IsPacked : Boolean;
Function InterfaceGUID : string;
Function IsSealed : Boolean;
Function IsAbstract : Boolean;
Function HasModifier(const aModifier: String): Boolean;
end;
@ -821,7 +829,8 @@ type
TProcedureModifier = (pmVirtual, pmDynamic, pmAbstract, pmOverride,
pmExport, pmOverload, pmMessage, pmReintroduce,
pmStatic,pmInline,pmAssembler,pmVarargs, pmPublic,
pmCompilerProc,pmExternal,pmForward, pmDispId, pmNoReturn);
pmCompilerProc,pmExternal,pmForward, pmDispId,
pmNoReturn, pmfar);
TProcedureModifiers = Set of TProcedureModifier;
TProcedureMessageType = (pmtNone,pmtInteger,pmtString);
@ -845,9 +854,9 @@ type
public
ProcType : TPasProcedureType;
Body : TProcedureBody;
PublicName,
PublicName, // e.g. public PublicName;
LibrarySymbolName,
LibraryExpr : TPasExpr;
LibraryExpr : TPasExpr; // e.g. external LibraryExpr name LibrarySymbolName;
DispIDExpr : TPasExpr;
AliasName : String;
Procedure AddModifier(AModifier : TProcedureModifier);
@ -1217,6 +1226,7 @@ Type
end;
{ TPasImplForLoop }
TLoopType = (ltNormal,ltDown,ltIn);
TPasImplForLoop = class(TPasImplStatement)
public
@ -1340,6 +1350,7 @@ Type
const
AccessNames: array[TArgumentAccess] of string[9] = ('', 'const ', 'var ', 'out ','constref ');
AccessDescriptions: array[TArgumentAccess] of string[9] = ('default', 'const', 'var', 'out','constref');
AllVisibilities: TPasMemberVisibilities =
[visDefault, visPrivate, visProtected, visPublic,
visPublished, visAutomated];
@ -1404,7 +1415,8 @@ const
= ('virtual', 'dynamic','abstract', 'override',
'export', 'overload', 'message', 'reintroduce',
'static','inline','assembler','varargs', 'public',
'compilerproc','external','forward','dispid','noreturn');
'compilerproc','external','forward','dispid',
'noreturn','far');
VariableModifierNames : Array[TVariableModifier] of string
= ('cvar', 'external', 'public', 'export', 'class', 'static');
@ -2309,6 +2321,8 @@ begin
okSpecialize : Result := SPasTreeSpecializedType;
okClassHelper : Result:=SPasClassHelperType;
okRecordHelper : Result:=SPasRecordHelperType;
else
Result:='ObjKind('+IntToStr(ord(ObjKind))+')';
end;
end;
@ -2330,6 +2344,21 @@ begin
ForEachChildCall(aMethodCall,Arg,TPasElement(GenericTemplateTypes[i]),false);
end;
procedure TPasClassType.SetGenericTemplates(AList: TFPList);
Var
I : Integer;
begin
ObjKind:=okGeneric;
For I:=0 to AList.Count-1 do
begin
TPasElement(AList[i]).Parent:=Self;
GenericTemplateTypes.Add(AList[i]);
end;
ObjKind:=okGeneric;
end;
function TPasClassType.FindMember(MemberClass: TPTreeElement; const MemberName: String): TPasElement;
Var
@ -2381,6 +2410,26 @@ begin
Result:=''
end;
function TPasClassType.IsSealed: Boolean;
begin
Result:=HasModifier('sealed');
end;
function TPasClassType.IsAbstract: Boolean;
begin
Result:=HasModifier('abstract');
end;
function TPasClassType.HasModifier(const aModifier: String): Boolean;
var
i: Integer;
begin
for i:=0 to Modifiers.Count-1 do
if CompareText(aModifier,Modifiers[i])=0 then
exit(true);
Result:=false;
end;
function TPasClassType.IsPacked: Boolean;
begin
Result:=PackMode<>pmNone;
@ -2648,7 +2697,7 @@ begin
if IfBranch=nil then
begin
IfBranch:=Element;
element.AddRef;
Element.AddRef;
end
else if ElseBranch=nil then
begin
@ -2667,10 +2716,12 @@ end;
procedure TPasImplIfElse.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
begin
inherited ForEachCall(aMethodCall, Arg);
ForEachChildCall(aMethodCall,Arg,ConditionExpr,false);
ForEachChildCall(aMethodCall,Arg,IfBranch,false);
ForEachChildCall(aMethodCall,Arg,ElseBranch,false);
if Elements.IndexOf(IfBranch)<0 then
ForEachChildCall(aMethodCall,Arg,IfBranch,false);
if Elements.IndexOf(ElseBranch)<0 then
ForEachChildCall(aMethodCall,Arg,ElseBranch,false);
inherited ForEachCall(aMethodCall, Arg);
end;
function TPasImplIfElse.Condition: string;
@ -2704,12 +2755,13 @@ end;
procedure TPasImplForLoop.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
begin
inherited ForEachCall(aMethodCall, Arg);
ForEachChildCall(aMethodCall,Arg,VariableName,false);
ForEachChildCall(aMethodCall,Arg,Variable,false);
ForEachChildCall(aMethodCall,Arg,StartExpr,false);
ForEachChildCall(aMethodCall,Arg,EndExpr,false);
ForEachChildCall(aMethodCall,Arg,Body,false);
if Elements.IndexOf(Body)<0 then
ForEachChildCall(aMethodCall,Arg,Body,false);
inherited ForEachCall(aMethodCall, Arg);
end;
function TPasImplForLoop.Down: boolean;
@ -3886,15 +3938,16 @@ begin
Body.AddRef;
end
else
raise Exception.Create('TPasImplWhileDo.AddElement body already set - please report this bug');
raise Exception.Create('TPasImplWhileDo.AddElement body already set');
end;
procedure TPasImplWhileDo.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
begin
inherited ForEachCall(aMethodCall, Arg);
ForEachChildCall(aMethodCall,Arg,ConditionExpr,false);
ForEachChildCall(aMethodCall,Arg,Body,false);
if Elements.IndexOf(Body)<0 then
ForEachChildCall(aMethodCall,Arg,Body,false);
inherited ForEachCall(aMethodCall, Arg);
end;
function TPasImplWhileDo.Condition: string;
@ -3937,9 +3990,10 @@ end;
procedure TPasImplCaseOf.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
begin
inherited ForEachCall(aMethodCall, Arg);
ForEachChildCall(aMethodCall,Arg,CaseExpr,false);
ForEachChildCall(aMethodCall,Arg,ElseBranch,false);
if Elements.IndexOf(ElseBranch)<0 then
ForEachChildCall(aMethodCall,Arg,ElseBranch,false);
inherited ForEachCall(aMethodCall, Arg);
end;
function TPasImplCaseOf.Expression: string;
@ -3980,6 +4034,8 @@ begin
Body:=Element;
Body.AddRef;
end
else
raise Exception.Create('TPasImplCaseStatement.AddElement body already set');
end;
procedure TPasImplCaseStatement.AddExpression(const Expr: TPasExpr);
@ -3993,10 +4049,11 @@ procedure TPasImplCaseStatement.ForEachCall(
var
i: Integer;
begin
inherited ForEachCall(aMethodCall, Arg);
for i:=0 to Expressions.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(Expressions[i]),false);
ForEachChildCall(aMethodCall,Arg,Body,false);
if Elements.IndexOf(Body)<0 then
ForEachChildCall(aMethodCall,Arg,Body,false);
inherited ForEachCall(aMethodCall, Arg);
end;
{ TPasImplWithDo }
@ -4026,7 +4083,9 @@ begin
begin
Body:=Element;
Body.AddRef;
end;
end
else
raise Exception.Create('TPasImplWithDo.AddElement body already set');
end;
procedure TPasImplWithDo.AddExpression(const Expression: TPasExpr);
@ -4039,10 +4098,11 @@ procedure TPasImplWithDo.ForEachCall(const aMethodCall: TOnForEachPasElement;
var
i: Integer;
begin
inherited ForEachCall(aMethodCall, Arg);
for i:=0 to Expressions.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(Expressions[i]),false);
ForEachChildCall(aMethodCall,Arg,Body,false);
if Elements.IndexOf(Body)<0 then
ForEachChildCall(aMethodCall,Arg,Body,false);
inherited ForEachCall(aMethodCall, Arg);
end;
{ TPasImplTry }
@ -4105,10 +4165,11 @@ end;
procedure TPasImplExceptOn.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
begin
inherited ForEachCall(aMethodCall, Arg);
ForEachChildCall(aMethodCall,Arg,VarEl,false);
ForEachChildCall(aMethodCall,Arg,TypeEl,false);
ForEachChildCall(aMethodCall,Arg,Body,false);
if Elements.IndexOf(Body)<0 then
ForEachChildCall(aMethodCall,Arg,Body,false);
inherited ForEachCall(aMethodCall, Arg);
end;
function TPasImplExceptOn.VariableName: String;

1843
packages/fcl-passrc/src/pasuseanalyzer.pas Normal file
View File

File diff suppressed because it is too large Load Diff

363
packages/fcl-passrc/src/pparser.pp
View File

@ -75,6 +75,7 @@ const
nParserOnlyOneVariableCanBeInitialized = 2048;
nParserExpectedTypeButGot = 2049;
nParserPropertyArgumentsCanNotHaveDefaultValues = 2050;
nParserExpectedExternalClassName = 2051;
// resourcestring patterns of messages
resourcestring
@ -128,6 +129,7 @@ resourcestring
SParserOnlyOneVariableCanBeInitialized = 'Only one variable can be initialized';
SParserExpectedTypeButGot = 'Expected type, but got %s';
SParserPropertyArgumentsCanNotHaveDefaultValues = 'Property arguments can not have default values';
SParserExpectedExternalClassName = 'Expected external class name';
type
TPasScopeType = (
@ -240,7 +242,7 @@ type
procedure DumpCurToken(Const Msg : String; IndentAction : TIndentAction = iaNone);
function GetCurrentModeSwitches: TModeSwitches;
Procedure SetCurrentModeSwitches(AValue: TModeSwitches);
function GetVariableModifiers(Parent: TPasElement; Out VarMods: TVariableModifiers; Out LibName, ExportName: TPasExpr): string;
function GetVariableModifiers(Parent: TPasElement; Out VarMods: TVariableModifiers; Out LibName, ExportName: TPasExpr; ExternalClass : Boolean): string;
function GetVariableValueAndLocation(Parent : TPasElement; Out Value : TPasExpr; Out Location: String): Boolean;
procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier);
procedure ParseClassLocalConsts(AType: TPasClassType; AVisibility: TPasMemberVisibility);
@ -280,9 +282,9 @@ type
function CreatePrimitiveExpr(AParent: TPasElement; AKind: TPasExprKind; const AValue: String): TPrimitiveExpr;
function CreateBoolConstExpr(AParent: TPasElement; AKind: TPasExprKind; const ABoolValue : Boolean): TBoolConstExpr;
function CreateBinaryExpr(AParent : TPasElement; xleft, xright: TPasExpr; AOpCode: TExprOpCode): TBinaryExpr;
procedure AddToBinaryExprChain(var ChainFirst, ChainLast: TPasExpr;
procedure AddToBinaryExprChain(var ChainFirst: TPasExpr;
Element: TPasExpr; AOpCode: TExprOpCode);
procedure AddParamsToBinaryExprChain(var ChainFirst, ChainLast: TPasExpr;
procedure AddParamsToBinaryExprChain(var ChainFirst: TPasExpr;
Params: TParamsExpr);
{$IFDEF VerbosePasParser}
procedure WriteBinaryExprChain(Prefix: string; First, Last: TPasExpr);
@ -290,7 +292,7 @@ type
function CreateUnaryExpr(AParent : TPasElement; AOperand: TPasExpr; AOpCode: TExprOpCode): TUnaryExpr;
function CreateArrayValues(AParent : TPasElement): TArrayValues;
function CreateFunctionType(const AName, AResultName: String; AParent: TPasElement;
UseParentAsResultParent: Boolean): TPasFunctionType;
UseParentAsResultParent: Boolean; const NamePos: TPasSourcePos): TPasFunctionType;
function CreateInheritedExpr(AParent : TPasElement): TInheritedExpr;
function CreateSelfExpr(AParent : TPasElement): TSelfExpr;
function CreateNilExpr(AParent : TPasElement): TNilExpr;
@ -331,7 +333,7 @@ type
// Type declarations
function ParseComplexType(Parent : TPasElement = Nil): TPasType;
function ParseTypeDecl(Parent: TPasElement): TPasType;
function ParseType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName : String = ''; Full : Boolean = False): TPasType;
function ParseType(Parent: TPasElement; const NamePos: TPasSourcePos; const TypeName: String = ''; Full: Boolean = false; GenericArgs: TFPList = nil): TPasType;
function ParseProcedureType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String; const PT: TProcType): TPasProcedureType;
function ParseStringType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String): TPasAliasType;
function ParseSimpleType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String; IsFull : Boolean = False): TPasType;
@ -343,7 +345,7 @@ type
function ParseEnumType(Parent: TPasElement; Const NamePos: TPasSourcePos; const TypeName: String): TPasEnumType;
function ParseSetType(Parent: TPasElement; Const NamePos: TPasSourcePos; const TypeName: String; AIsPacked : Boolean = False): TPasSetType;
function ParseSpecializeType(Parent: TPasElement; Const TypeName: String): TPasClassType;
Function ParseClassDecl(Parent: TPasElement; Const NamePos: TPasSourcePos; Const AClassName: String; AObjKind: TPasObjKind; PackMode : TPackMode= pmNone): TPasType;
Function ParseClassDecl(Parent: TPasElement; Const NamePos: TPasSourcePos; Const AClassName: String; AObjKind: TPasObjKind; PackMode : TPackMode= pmNone; GenericArgs: TFPList = nil): TPasType;
Function ParseProperty(Parent : TPasElement; Const AName : String; AVisibility : TPasMemberVisibility; IsClassField: boolean) : TPasProperty;
function ParseRangeType(AParent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String; Full: Boolean = True): TPasRangeType;
procedure ParseExportDecl(Parent: TPasElement; List: TFPList);
@ -713,8 +715,11 @@ end;
procedure TPasParser.ParseExc(MsgNumber: integer; const Fmt: String;
Args: array of const);
begin
{$IFDEF VerbosePasParser}
writeln('TPasParser.ParseExc Token="',CurTokenText,'"');
{$ENDIF}
SetLastMsg(mtError,MsgNumber,Fmt,Args);
raise EParserError.Create(Format(SParserErrorAtToken,
raise EParserError.Create(SafeFormat(SParserErrorAtToken,
[FLastMsg, CurTokenName, Scanner.CurFilename, Scanner.CurRow, Scanner.CurColumn])
{$ifdef addlocation}+' ('+inttostr(scanner.currow)+' '+inttostr(scanner.curcolumn)+')'{$endif},
Scanner.CurFilename, Scanner.CurRow, Scanner.CurColumn);
@ -832,8 +837,20 @@ begin
until not (FCurToken in WhitespaceTokensToIgnore);
except
on e: EScannerError do
raise EParserError.Create(e.Message,
Scanner.CurFilename, Scanner.CurRow, Scanner.CurColumn);
begin
if po_KeepScannerError in Options then
raise e
else
begin
FLastMsgType := mtError;
FLastMsgNumber := Scanner.LastMsgNumber;
FLastMsgPattern := Scanner.LastMsgPattern;
FLastMsg := Scanner.LastMsg;
FLastMsgArgs := Scanner.LastMsgArgs;
raise EParserError.Create(e.Message,
Scanner.CurFilename, Scanner.CurRow, Scanner.CurColumn);
end;
end;
end;
FCurTokenString := Scanner.CurTokenString;
FTokenBuffer[FTokenBufferSize] := FCurToken;
@ -1080,6 +1097,11 @@ begin
ParseExcTokenError(';');
UnGetToken;
end
else if (CurToken = tkLessThan) then // A = B<t>;
begin
K:=stkSpecialize;
UnGetToken;
end
else if (CurToken in [tkBraceOpen,tkDotDot]) then // A: B..C;
begin
K:=stkRange;
@ -1247,7 +1269,7 @@ begin
end;
function TPasParser.ParseType(Parent: TPasElement;
const NamePos: TPasSourcePos; const TypeName: String; Full: Boolean
const NamePos: TPasSourcePos; const TypeName: String = ''; Full: Boolean = false; GenericArgs : TFPList = Nil
): TPasType;
Const
@ -1280,7 +1302,7 @@ begin
tkInterface:
Result := ParseClassDecl(Parent, NamePos, TypeName, okInterface);
tkSpecialize: Result:=ParseSpecializeType(Parent,TypeName);
tkClass: Result := ParseClassDecl(Parent, NamePos, TypeName, okClass, PM);
tkClass: Result := ParseClassDecl(Parent, NamePos, TypeName, okClass, PM, GenericArgs);
tkType:
begin
NextToken;
@ -1345,7 +1367,7 @@ begin
end;
tkFunction:
begin
Result := CreateFunctionType('', 'Result', Parent, False);
Result := CreateFunctionType('', 'Result', Parent, False, Scanner.CurSourcePos);
ParseProcedureOrFunctionHeader(Result, TPasFunctionType(Result), ptFunction, True);
if CurToken = tkSemicolon then
UngetToken; // Unget semicolon
@ -1575,7 +1597,7 @@ function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr;
end;
var
Last , Expr: TPasExpr;
Last,func, Expr: TPasExpr;
prm : TParamsExpr;
b : TBinaryExpr;
optk : TToken;
@ -1649,7 +1671,8 @@ begin
end;
Result:=Last;
func:=Last;
if Last.Kind<>pekSet then NextToken;
ok:=false;
@ -1661,8 +1684,9 @@ begin
NextToken;
if CurToken in [tkIdentifier,tktrue,tkfalse] then // true and false are also identifiers
begin
AddToBinaryExprChain(Result,Last,
CreatePrimitiveExpr(AParent,pekIdent,CurTokenString), eopSubIdent);
expr:=CreatePrimitiveExpr(AParent,pekIdent,CurTokenString);
AddToBinaryExprChain(Result,expr,eopSubIdent);
func:=expr;
NextToken;
end
else
@ -1671,21 +1695,20 @@ begin
ParseExcExpectedIdentifier;
end;
end;
repeat
repeat
case CurToken of
tkBraceOpen,tkSquaredBraceOpen:
begin
if CurToken=tkBraceOpen then
prm:=ParseParams(AParent,pekFuncParams,isWriteOrStr(Last))
prm:=ParseParams(AParent,pekFuncParams,isWriteOrStr(func))
else
prm:=ParseParams(AParent,pekArrayParams);
if not Assigned(prm) then Exit;
AddParamsToBinaryExprChain(Result,Last,prm);
AddParamsToBinaryExprChain(Result,prm);
end;
tkCaret:
begin
Result:=CreateUnaryExpr(AParent,Result,TokenToExprOp(CurToken));
Last:=Result;
NextToken;
end;
else
@ -1701,7 +1724,7 @@ begin
if Expr=nil then
ParseExcExpectedIdentifier;
if optk=tkDot then
AddToBinaryExprChain(Result,Last,Expr,TokenToExprOp(optk))
AddToBinaryExprChain(Result,Expr,TokenToExprOp(optk))
else
begin
// a as b
@ -1847,7 +1870,7 @@ begin
if (CurToken<>tkBraceClose) then
begin
x.Release;
Exit;
CheckToken(tkBraceClose);
end;
NextToken;
// for expressions like (ppdouble)^^;
@ -1868,7 +1891,7 @@ begin
x:=ParseExpIdent(AParent);
end;
if not Assigned(x) then
Exit;
ParseExcSyntaxError;
expstack.Add(x);
for i:=1 to pcount do
@ -1901,7 +1924,7 @@ begin
PushOper(CurToken);
NextToken;
end;
// Writeln('Bin ',NotBinary ,' or EOE ',isEndOfExp, ' Ex ',Assigned(x),' stack ',ExpStack.Count);
//Writeln('Bin ',NotBinary ,' or EOE ',isEndOfExp, ' Ex ',Assigned(x),' stack ',ExpStack.Count);
until NotBinary or isEndOfExp(AllowEqual);
if not NotBinary then ParseExcExpectedIdentifier;
@ -1909,6 +1932,8 @@ begin
while opstackTop>=0 do PopAndPushOperator;
// only 1 expression should be on the stack, at the end of the correct expression
if expstack.Count<>1 then
ParseExcSyntaxError;
if expstack.Count=1 then
begin
Result:=TPasExpr(expstack[0]);
@ -2477,20 +2502,20 @@ begin
SetBlock(declProperty);
tkProcedure, tkFunction, tkConstructor, tkDestructor,tkOperator:
begin
SetBlock(declNone);
SaveComments;
pt:=GetProcTypeFromToken(CurToken);
AddProcOrFunction(Declarations, ParseProcedureOrFunctionDecl(Declarations, pt));
SetBlock(declNone);
end;
tkClass:
begin
SetBlock(declNone);
SaveComments;
NextToken;
If CurToken in [tkprocedure,tkFunction,tkConstructor, tkDestructor] then
begin
pt:=GetProcTypeFromToken(CurToken,True);
AddProcOrFunction(Declarations,ParseProcedureOrFunctionDecl(Declarations, pt));
SetBlock(declNone);
end
else
ExpectToken(tkprocedure);
@ -2579,6 +2604,7 @@ begin
Declarations.Declarations.Add(VarEl);
Declarations.Variables.Add(VarEl);
end;
CheckToken(tkSemicolon);
finally
List.Free;
end;
@ -2605,16 +2631,12 @@ begin
ExpectToken(tkEqual);
NextToken;
Case CurToken of
tkObject,
tkClass :
begin
ClassEl := TPasClassType(CreateElement(TPasClassType,
TypeName, Declarations, NamePos));
ClassEl.ObjKind:=okGeneric;
For I:=0 to List.Count-1 do
begin
TPasElement(List[i]).Parent:=ClassEl;
ClassEl.GenericTemplateTypes.Add(List[i]);
end;
ClassEl.SetGenericTemplates(List);
NextToken;
DoParseClassType(ClassEl);
Declarations.Declarations.Add(ClassEl);
@ -2777,6 +2799,8 @@ var
begin
SaveComments;
Result := TPasConst(CreateElement(TPasConst, CurTokenString, Parent));
if Parent is TPasClassType then
Include(Result.VarModifiers,vmClass);
ok:=false;
try
NextToken;
@ -2908,22 +2932,9 @@ end;
function TPasParser.ParseSpecializeType(Parent: TPasElement;
const TypeName: String): TPasClassType;
var
ok: Boolean;
begin
Result := TPasClassType(CreateElement(TPasClassType, TypeName, Parent,
Scanner.CurSourcePos));
ok:=false;
try
Result.ObjKind := okSpecialize;
Result.AncestorType := ParseType(Result,Scanner.CurSourcePos);
Result.IsShortDefinition:=True;
ReadGenericArguments(TPasClassType(Result).GenericTemplateTypes,Result);
ok:=true;
finally
if not ok then
Result.Release;
end;
NextToken;
Result:=ParseSimpleType(Parent,Scanner.CurSourcePos,TypeName) as TPasClassType;
end;
function TPasParser.ParseProcedureType(Parent: TPasElement;
@ -2934,7 +2945,7 @@ var
ok: Boolean;
begin
if PT in [ptFunction,ptClassFunction] then
Result := CreateFunctionType(TypeName, 'Result', Parent, False)
Result := CreateFunctionType(TypeName, 'Result', Parent, False, NamePos)
else
Result := TPasProcedureType(CreateElement(TPasProcedureType, TypeName, Parent, NamePos));
ok:=false;
@ -2953,16 +2964,25 @@ var
TypeName: String;
NamePos: TPasSourcePos;
OldForceCaret : Boolean;
List : TFPList;
begin
TypeName := CurTokenString;
NamePos:=Scanner.CurSourcePos;
ExpectToken(tkEqual);
List:=Nil;
OldForceCaret:=Scanner.SetForceCaret(True);
try
Result:=ParseType(Parent,NamePos,TypeName,True);
NextToken;
if (CurToken=tkLessThan) and (msDelphi in CurrentModeswitches) then
List:=TFPList.Create;
UnGetToken; // ReadGenericArguments starts at <
if Assigned(List) then
ReadGenericArguments(List,Parent);
ExpectToken(tkEqual);
Result:=ParseType(Parent,NamePos,TypeName,True,List);
finally
Scanner.SetForceCaret(OldForceCaret);
List.Free;
end;
end;
@ -2998,7 +3018,8 @@ begin
end;
function TPasParser.GetVariableModifiers(Parent: TPasElement; out
VarMods: TVariableModifiers; out LibName, ExportName: TPasExpr): string;
VarMods: TVariableModifiers; out LibName, ExportName: TPasExpr;
ExternalClass: Boolean): string;
Var
S : String;
@ -3009,7 +3030,7 @@ begin
ExportName := nil;
VarMods := [];
NextToken;
If CurTokenIsIdentifier('cvar') then
If CurTokenIsIdentifier('cvar') and not ExternalClass then
begin
Result:=';cvar';
Include(VarMods,vmcvar);
@ -3019,9 +3040,9 @@ begin
s:=LowerCase(CurTokenText);
if s='external' then
ExtMod:=vmExternal
else if (s='public') then
else if (s='public') and not externalclass then
ExtMod:=vmPublic
else if (s='export') then
else if (s='export') and not externalclass then
ExtMod:=vmExport
else
begin
@ -3046,7 +3067,7 @@ begin
// external libname name exportname;
// external name exportname;
if (ExtMod=vmExternal) and (CurToken in [tkString,tkIdentifier])
and Not (CurTokenIsIdentifier('name')) then
and Not (CurTokenIsIdentifier('name')) and not ExternalClass then
begin
Result := Result + ' ' + CurTokenText;
LibName:=DoParseExpression(Parent);
@ -3073,7 +3094,7 @@ var
H : TPasMemberHints;
VarMods: TVariableModifiers;
D,Mods,Loc: string;
OldForceCaret,ok: Boolean;
OldForceCaret,ok,ExternalClass: Boolean;
begin
Value:=Nil;
@ -3119,13 +3140,25 @@ begin
TPasVariable(VarList[OldListCount]).Expr:=Value;
Value:=nil;
H:=H+CheckHint(Nil,Full);
if Full then
Mods:=GetVariableModifiers(Parent,VarMods,aLibName,aExpName)
// Note: external members are allowed for non external classes too
ExternalClass:=(msExternalClass in CurrentModeSwitches)
and (Parent is TPasClassType);
H:=H+CheckHint(Nil,False);
if Full or Externalclass then
begin
NextToken;
If Curtoken<>tkSemicolon then
UnGetToken;
Mods:=GetVariableModifiers(Parent,VarMods,aLibName,aExpName,ExternalClass);
if (mods='') and (CurToken<>tkSemicolon) then
NextToken;
end
else
begin
NextToken;
VarMods:=[];
Mods:='';
end;
SaveComments(D);
@ -3201,7 +3234,7 @@ begin
FLastMsgType := MsgType;
FLastMsgNumber := MsgNumber;
FLastMsgPattern := Fmt;
FLastMsg := Format(Fmt,Args);
FLastMsg := SafeFormat(Fmt,Args);
CreateMsgArgs(FLastMsgArgs,Args);
end;
@ -3400,11 +3433,19 @@ Var
P : TPasProcedure;
E : TPasExpr;
begin
if Parent is TPasProcedure then
P:=TPasProcedure(Parent);
if Assigned(P) then
procedure AddModifier;
begin
if pm in P.Modifiers then
ParseExcSyntaxError;
P.AddModifier(pm);
end;
begin
if not (Parent is TPasProcedure) then
exit;
P:=TPasProcedure(Parent);
if pm<>pmPublic then
AddModifier;
Case pm of
pmExternal:
begin
@ -3443,16 +3484,22 @@ begin
pmPublic:
begin
NextToken;
{ Should be token Name,
if not we're in a class and the public section starts }
If (Uppercase(CurTokenString)<>'NAME') then
If not CurTokenIsIdentifier('name') then
begin
UngetToken;
UngetToken;
if P.Parent is TPasClassType then
begin
// public section starts
UngetToken;
UngetToken;
exit;
end;
AddModifier;
CheckToken(tkSemicolon);
exit;
end
else
begin
AddModifier;
NextToken; // Should be export name string.
if not (CurToken in [tkString,tkIdentifier]) then
ParseExcTokenError(TokenInfos[tkString]);
@ -3561,7 +3608,6 @@ Var
PM : TProcedureModifier;
Done: Boolean;
ResultEl: TPasResultElement;
I : Integer;
OK : Boolean;
begin
@ -3647,7 +3693,7 @@ begin
UngetToken;
Repeat
NextToken;
If TokenisCallingConvention(CurTokenString,cc) then
If TokenIsCallingConvention(CurTokenString,cc) then
begin
Element.CallingConvention:=Cc;
if cc = ccSysCall then
@ -3696,7 +3742,9 @@ begin
NextToken
until CurToken = tkSquaredBraceClose;
ExpectToken(tkSemicolon);
end;
end
else if CurToken<>tkSemicolon then
CheckToken(tkSemicolon);
Done:=(CurToken=tkSemiColon);
if Done then
begin
@ -3745,14 +3793,12 @@ function TPasParser.ParseProperty(Parent: TPasElement; const AName: String;
function GetAccessorName(aParent: TPasElement; out Expr: TPasExpr): String;
var
Last: TPasExpr;
Params: TParamsExpr;
Param: TPasExpr;
begin
ExpectIdentifier;
Result := CurTokenString;
Expr := CreatePrimitiveExpr(aParent,pekIdent,CurTokenString);
Last := Expr;
// read .subident.subident...
repeat
@ -3760,7 +3806,7 @@ function TPasParser.ParseProperty(Parent: TPasElement; const AName: String;
if CurToken <> tkDot then break;
ExpectIdentifier;
Result := Result + '.' + CurTokenString;
AddToBinaryExprChain(Expr,Last,CreatePrimitiveExpr(aParent,pekIdent,CurTokenString),eopSubIdent);
AddToBinaryExprChain(Expr,CreatePrimitiveExpr(aParent,pekIdent,CurTokenString),eopSubIdent);
until false;
// read optional array index
@ -3771,7 +3817,7 @@ function TPasParser.ParseProperty(Parent: TPasElement; const AName: String;
Result := Result + '[';
Params:=TParamsExpr(CreateElement(TParamsExpr,'',aParent));
Params.Kind:=pekArrayParams;
AddParamsToBinaryExprChain(Expr,Last,Params);
AddParamsToBinaryExprChain(Expr,Params);
NextToken;
case CurToken of
tkChar: Param:=CreatePrimitiveExpr(aParent,pekString, CurTokenText);
@ -3795,7 +3841,7 @@ function TPasParser.ParseProperty(Parent: TPasElement; const AName: String;
end;
ExpectIdentifier;
Result := Result + '.' + CurTokenString;
AddToBinaryExprChain(Expr,Last,CreatePrimitiveExpr(aParent,pekIdent,CurTokenString),eopSubIdent);
AddToBinaryExprChain(Expr,CreatePrimitiveExpr(aParent,pekIdent,CurTokenString),eopSubIdent);
until false;
end;
@ -4057,14 +4103,16 @@ begin
while True do
begin
NextToken;
//WriteLn('Token=',CurTokenText);
WriteLn({$IFDEF VerbosePasParser}i,{$ENDIF}' Token=',CurTokenText);
case CurToken of
tkasm:
begin
El:=TPasImplElement(CreateElement(TPasImplAsmStatement,'',CurBlock));
ParseAsmBlock(TPasImplAsmStatement(El));
CurBlock.AddElement(El);
NewImplElement:=El;
if NewImplElement=nil then NewImplElement:=CurBlock;
if CloseStatement(true) then
break;
end;
tkbegin:
begin
@ -4156,7 +4204,7 @@ begin
begin
NextToken;
curblock.AddCommand('goto '+curtokenstring);
expecttoken(tkSemiColon);
// expecttoken(tkSemiColon);
end;
tkfor:
begin
@ -4167,7 +4215,6 @@ begin
Try
ExpectIdentifier;
Left:=CreatePrimitiveExpr(El,pekIdent,CurTokenString);
Right:=Left;
TPasImplForLoop(El).VariableName:=Left;
repeat
NextToken;
@ -4185,7 +4232,7 @@ begin
tkDot:
begin
ExpectIdentifier;
AddToBinaryExprChain(Left,Right,
AddToBinaryExprChain(Left,
CreatePrimitiveExpr(El,pekIdent,CurTokenString), eopSubIdent);
TPasImplForLoop(El).VariableName:=Left;
end;
@ -4449,7 +4496,10 @@ begin
end else
ParseExcSyntaxError;
end;
else
tkEOF:
CheckToken(tkend);
tkBraceOpen,tkIdentifier,tkNumber,tkSquaredBraceOpen,tkMinus,tkPlus,tkinherited:
begin
left:=DoParseExpression(CurBlock);
case CurToken of
tkAssign,
@ -4494,6 +4544,9 @@ begin
if not (CmdElem is TPasImplLabelMark) then
if NewImplElement=nil then NewImplElement:=CmdElem;
end;
else
ParseExcSyntaxError;
end;
end;
end;
@ -4534,15 +4587,33 @@ end;
function TPasParser.ParseProcedureOrFunctionDecl(Parent: TPasElement; ProcType: TProcType;AVisibility : TPasMemberVisibility = VisDefault): TPasProcedure;
function ExpectProcName: string;
Var
L : TFPList;
I : Integer;
begin
Result:=ExpectIdentifier;
//writeln('ExpectProcName ',Parent.Classname);
if Parent is TImplementationSection then
begin
NextToken;
While CurToken=tkDot do
While CurToken in [tkDot,tkLessThan] do
begin
Result:=Result+'.'+ExpectIdentifier;
if CurToken=tkDot then
Result:=Result+'.'+ExpectIdentifier
else
begin // <> can be ignored, we read the list but discard its content
UnGetToken;
L:=TFPList.Create;
Try
ReadGenericArguments(L,Parent);
finally
For I:=0 to L.Count-1 do
TPasElement(L[i]).Release;
L.Free;
end;
end;
NextToken;
end;
UngetToken;
@ -4579,7 +4650,7 @@ begin
Result.ProcType := TPasProcedureType(CreateElement(TPasProcedureType, '', Result))
else
begin
Result.ProcType := CreateFunctionType('', 'Result', Result, True);
Result.ProcType := CreateFunctionType('', 'Result', Result, True, Scanner.CurSourcePos);
if (ProcType in [ptOperator, ptClassOperator]) then
begin
TPasOperator(Result).TokenBased:=IsTokenBased;
@ -5009,18 +5080,23 @@ begin
SaveComments;
ExpectIdentifier;
AType.Members.Add(ParseProperty(AType,CurtokenString,CurVisibility,false));
end;
end
else
CheckToken(tkIdentifier);
end;
NextToken;
end;
end;
procedure TPasParser.DoParseClassType(AType: TPasClassType);
var
Element : TPasElement;
s: String;
CT : TPasClassType;
begin
ct:=Nil;
// nettism/new delphi features
if (CurToken=tkIdentifier) and (Atype.ObjKind in [okClass,okGeneric]) then
begin
@ -5036,11 +5112,28 @@ begin
if (CurToken=tkBraceOpen) then
begin
AType.AncestorType := ParseType(AType,Scanner.CurSourcePos);
NextToken;
if curToken=tkLessthan then
CT := TPasClassType(CreateElement(TPasClassType, AType.AncestorType.Name, AType.Parent, Scanner.CurSourcePos));
UnGetToken ;
if Assigned(CT) then
try
CT.ObjKind := okSpecialize;
CT.AncestorType := TPasUnresolvedTypeRef.Create(AType.AncestorType.Name,AType.Parent);
CT.IsShortDefinition:=True;
ReadGenericArguments(CT.GenericTemplateTypes,CT);
AType.AncestorType.Release;
AType.AncestorType:=CT;
CT:=Nil;
Finally
FreeAndNil(CT);
end;
while True do
begin
NextToken;
if CurToken = tkBraceClose then
break;
break ;
UngetToken;
ExpectToken(tkComma);
Element:=ParseType(AType,Scanner.CurSourcePos,'',False); // search interface.
@ -5076,12 +5169,13 @@ end;
function TPasParser.ParseClassDecl(Parent: TPasElement;
const NamePos: TPasSourcePos; const AClassName: String;
AObjKind: TPasObjKind; PackMode: TPackMode): TPasType;
AObjKind: TPasObjKind; PackMode: TPackMode; GenericArgs: TFPList): TPasType;
Var
ok: Boolean;
FT : TPasType;
AExternalNameSpace,AExternalName : String;
PCT:TPasClassType;
begin
NextToken;
FT:=Nil;
@ -5095,13 +5189,32 @@ begin
Engine.FinishScope(stTypeDef,Result);
exit;
end;
if ((AobjKind in [okClass,OKInterface]) and (msExternalClass in CurrentModeswitches) and CurTokenIsIdentifier('external')) then
begin
NextToken;
if CurToken<>tkString then
UnGetToken
else
AExternalNameSpace:=CurTokenString;
ExpectIdentifier;
If Not CurTokenIsIdentifier('Name') then
ParseExc(nParserExpectedExternalClassName,SParserExpectedExternalClassName);
ExpectToken(tkString);
AExternalName:=CurTokenString;
NextToken;
end
else
begin
AExternalNameSpace:='';
AExternalName:='';
end;
if (CurTokenIsIdentifier('Helper')) then
begin
if Not (AObjKind in [okClass,okTypeHelper,okRecordHelper]) then
ParseExc(nParserHelperNotAllowed,SParserHelperNotAllowed,[ObjKindNames[AObjKind]]);
Case AObjKind of
okClass:
AObjKind:=okClassHelper;
AObjKind:=okClassHelper;
okTypeHelper:
begin
ExpectToken(tkFor);
@ -5110,14 +5223,22 @@ begin
end;
NextToken;
end;
Result := TPasClassType(CreateElement(TPasClassType, AClassName,
PCT := TPasClassType(CreateElement(TPasClassType, AClassName,
Parent, NamePos));
TPasClassType(Result).HelperForType:=FT;
Result:=PCT;
PCT.HelperForType:=FT;
PCT.IsExternal:=(AExternalName<>'');
if AExternalName<>'' then
PCT.ExternalName:=AnsiDequotedStr(AExternalName,'''');
if AExternalNameSpace<>'' then
PCT.ExternalNameSpace:=AnsiDequotedStr(AExternalNameSpace,'''');
ok:=false;
try
TPasClassType(Result).ObjKind := AObjKind;
TPasClassType(Result).PackMode:=PackMode;
DoParseClassType(TPasClassType(Result));
PCT.ObjKind := AObjKind;
PCT.PackMode:=PackMode;
if Assigned(GenericArgs) then
PCT.SetGenericTemplates(GenericArgs);
DoParseClassType(PCT);
Engine.FinishScope(stTypeDef,Result);
ok:=true;
finally
@ -5186,60 +5307,36 @@ begin
end;
end;
procedure TPasParser.AddToBinaryExprChain(var ChainFirst, ChainLast: TPasExpr;
procedure TPasParser.AddToBinaryExprChain(var ChainFirst: TPasExpr;
Element: TPasExpr; AOpCode: TExprOpCode);
procedure RaiseInternal;
begin
raise Exception.Create('TBinaryExpr.AddToChain: internal error');
end;
var
Last: TBinaryExpr;
begin
if Element=nil then
exit
else if ChainFirst=nil then
begin
// empty chain => simply add element, no need to create TBinaryExpr
if (ChainLast<>nil) then
RaiseInternal;
ChainFirst:=Element;
ChainLast:=Element;
end
else if ChainLast is TBinaryExpr then
begin
// add a new TBinaryExpr at the end of the chain
Last:=TBinaryExpr(ChainLast);
if (Last.left=nil) or (Last.right=nil) then
// chain not yet full => inconsistency
RaiseInternal;
Last.right:=CreateBinaryExpr(Last,Last.right,Element,AOpCode);
ChainLast:=Last.right;
end
else
begin
// one element => create a TBinaryExpr with two elements
if ChainFirst<>ChainLast then
RaiseInternal;
ChainLast:=CreateBinaryExpr(ChainLast.Parent,ChainLast,Element,AOpCode);
ChainFirst:=ChainLast;
// create new binary, old becomes left, Element right
ChainFirst:=CreateBinaryExpr(ChainFirst.Parent,ChainFirst,Element,AOpCode);
end;
end;
procedure TPasParser.AddParamsToBinaryExprChain(var ChainFirst,
ChainLast: TPasExpr; Params: TParamsExpr);
// append Params to chain, using the last element as Params.Value
procedure TPasParser.AddParamsToBinaryExprChain(var ChainFirst: TPasExpr;
Params: TParamsExpr);
// append Params to chain, using the last(right) element as Params.Value
var
Bin: TBinaryExpr;
begin
if Params.Value<>nil then
ParseExcSyntaxError;
if ChainLast=nil then
if ChainFirst=nil then
ParseExcSyntaxError;
if ChainLast is TBinaryExpr then
if ChainFirst is TBinaryExpr then
begin
Bin:=TBinaryExpr(ChainLast);
Bin:=TBinaryExpr(ChainFirst);
if Bin.left=nil then
ParseExcSyntaxError;
if Bin.right=nil then
@ -5251,13 +5348,10 @@ begin
end
else
begin
if ChainFirst<>ChainLast then
ParseExcSyntaxError;
Params.Value:=ChainFirst;
Params.Parent:=ChainFirst.Parent;
ChainFirst.Parent:=Params;
ChainFirst:=Params;
ChainLast:=Params;
end;
end;
@ -5340,11 +5434,12 @@ begin
end;
function TPasParser.CreateFunctionType(const AName, AResultName: String;
AParent: TPasElement; UseParentAsResultParent: Boolean): TPasFunctionType;
AParent: TPasElement; UseParentAsResultParent: Boolean;
const NamePos: TPasSourcePos): TPasFunctionType;
begin
Result:=Engine.CreateFunctionType(AName,AResultName,
AParent,UseParentAsResultParent,
Scanner.CurSourcePos);
NamePos);
end;
function TPasParser.CreateInheritedExpr(AParent: TPasElement): TInheritedExpr;

78
packages/fcl-passrc/src/pscanner.pp
View File

@ -237,7 +237,8 @@ type
msBlocks, { support for http://en.wikipedia.org/wiki/Blocks_(C_language_extension) }
msISOLikeIO, { I/O as it required by an ISO compatible compiler }
msISOLikeProgramsPara, { program parameters as it required by an ISO compatible compiler }
msISOLikeMod { mod operation as it is required by an iso compatible compiler }
msISOLikeMod, { mod operation as it is required by an iso compatible compiler }
msExternalClass { Allow external class definitions }
);
TModeSwitches = Set of TModeSwitch;
@ -378,13 +379,14 @@ type
TPOption = (
po_delphi, // DEPRECATED Delphi mode: forbid nested comments
po_cassignments, // allow C-operators += -= *= /=
po_resolvestandardtypes, // search for 'longint', 'string', etc., do not use dummies, TPasResolver sets this to use its declarations
po_asmwhole, // store whole text between asm..end in TPasImplAsmStatement.Tokens
po_nooverloadedprocs, // do not create TPasOverloadedProc for procs with same name
po_keepclassforward, // disabled: delete class fowards when there is a class declaration
po_arrayrangeexpr, // enable: create TPasArrayType.IndexRange, disable: create TPasArrayType.Ranges
po_selftoken // Self is a token. For backward compatibility.
po_KeepScannerError, // default: catch EScannerError and raise an EParserError instead
po_CAssignments, // allow C-operators += -= *= /=
po_ResolveStandardTypes, // search for 'longint', 'string', etc., do not use dummies, TPasResolver sets this to use its declarations
po_AsmWhole, // store whole text between asm..end in TPasImplAsmStatement.Tokens
po_NoOverloadedProcs, // do not create TPasOverloadedProc for procs with same name
po_KeepClassForward, // disabled: delete class fowards when there is a class declaration
po_ArrayRangeExpr, // enable: create TPasArrayType.IndexRange, disable: create TPasArrayType.Ranges
po_SelfToken // Self is a token. For backward compatibility.
);
TPOptions = set of TPOption;
@ -658,7 +660,8 @@ const
'CBLOCKS',
'ISOIO',
'ISOPROGRAMPARAS',
'ISOMOD'
'ISOMOD',
'EXTERNALCLASS'
);
const
@ -699,6 +702,7 @@ function FilenameIsUnixAbsolute(const TheFilename: string): boolean;
function IsNamedToken(Const AToken : String; Out T : TToken) : Boolean;
procedure CreateMsgArgs(var MsgArgs: TMessageArgs; Args: array of const);
function SafeFormat(const Fmt: string; Args: array of const): string;
implementation
@ -786,7 +790,6 @@ var
begin
SetLength(MsgArgs, High(Args)-Low(Args)+1);
for i:=Low(Args) to High(Args) do
begin
case Args[i].VType of
vtInteger: MsgArgs[i] := IntToStr(Args[i].VInteger);
vtBoolean: MsgArgs[i] := BoolToStr(Args[i].VBoolean);
@ -810,6 +813,26 @@ begin
vtQWord: MsgArgs[i] := IntToStr(Args[i].VQWord^);
vtUnicodeString:MsgArgs[i] := AnsiString(UnicodeString(Args[i].VUnicodeString));
end;
end;
function SafeFormat(const Fmt: string; Args: array of const): string;
var
MsgArgs: TMessageArgs;
i: Integer;
begin
try
Result:=Format(Fmt,Args);
except
Result:='';
MsgArgs:=nil;
CreateMsgArgs(MsgArgs,Args);
for i:=0 to length(MsgArgs)-1 do
begin
if i>0 then
Result:=Result+',';
Result:=Result+MsgArgs[i];
end;
Result:='{'+Fmt+'}['+Result+']';
end;
end;
@ -1309,7 +1332,8 @@ begin
FCurToken:=tkIdentifier;
Result:=FCurToken;
end;
Break;
if not (FSkipComments or PPIsSkipping) then
Break;
end;
else
if not PPIsSkipping then
@ -1961,7 +1985,8 @@ begin
TokenStart := TokenStr;
FCurTokenString := '';
OldLength := 0;
while (TokenStr[0] <> '*') or (TokenStr[1] <> ')') do
NestingLevel:=0;
while (TokenStr[0] <> '*') or (TokenStr[1] <> ')') or (NestingLevel>0) do
begin
if TokenStr[0] = #0 then
begin
@ -1980,7 +2005,16 @@ begin
TokenStart:=TokenStr;
end
else
begin
If (msNestedComment in CurrentModeSwitches) then
begin
if (TokenStr[0] = '(') and (TokenStr[1] = '*') then
Inc(NestingLevel)
else if (TokenStr[0] = '*') and (TokenStr[1] = ')') and not PPIsSkipping then
Dec(NestingLevel);
end;
Inc(TokenStr);
end;
end;
SectionLength := TokenStr - TokenStart;
SetLength(FCurTokenString, OldLength + SectionLength);
@ -2006,7 +2040,7 @@ begin
Inc(TokenStr);
Result := tkPower;
end
else if (po_cassignments in options) then
else if (po_CAssignments in options) then
begin
if TokenStr[0]='=' then
begin
@ -2019,7 +2053,7 @@ begin
begin
Result:=tkPlus;
Inc(TokenStr);
if (po_cassignments in options) then
if (po_CAssignments in options) then
begin
if TokenStr[0]='=' then
begin
@ -2037,7 +2071,7 @@ begin
begin
Result := tkMinus;
Inc(TokenStr);
if (po_cassignments in options) then
if (po_CAssignments in options) then
begin
if TokenStr[0]='=' then
begin
@ -2073,7 +2107,7 @@ begin
Move(TokenStart^, FCurTokenString[1], SectionLength);
Result := tkComment;
end
else if (po_cassignments in options) then
else if (po_CAssignments in options) then
begin
if TokenStr[0]='=' then
begin
@ -2289,7 +2323,7 @@ begin
If (TokenStr<>Nil) then
Result := TokenStr - PChar(CurLine)
else
Result:=0;
Result := 0;
end;
procedure TPascalScanner.DoLog(MsgType: TMessageType; MsgNumber: integer;
@ -2330,8 +2364,12 @@ function TPascalScanner.FetchLine: boolean;
begin
if CurSourceFile.IsEOF then
begin
FCurLine := '';
TokenStr := nil;
if TokenStr<>nil then
begin
FCurLine := '';
TokenStr := nil;
inc(FCurRow); // set CurRow to last line+1
end;
Result := false;
end else
begin
@ -2350,7 +2388,7 @@ begin
FLastMsgType := MsgType;
FLastMsgNumber := MsgNumber;
FLastMsgPattern := Fmt;
FLastMsg := Format(Fmt,Args);
FLastMsg := SafeFormat(Fmt,Args);
CreateMsgArgs(FLastMsgArgs,Args);
end;

11
packages/fcl-passrc/tests/tcbaseparser.pas
View File

@ -27,7 +27,7 @@ Type
{ TTestParser }
TTestParser= class(TTestCase)
TTestParser = class(TTestCase)
Private
FDeclarations: TPasDeclarations;
FDefinition: TPasElement;
@ -58,6 +58,7 @@ Type
Procedure StartImplementation;
Procedure EndSource;
Procedure Add(Const ALine : String);
Procedure Add(Const Lines : array of String);
Procedure StartParsing;
Procedure ParseDeclarations;
Procedure ParseModule;
@ -630,6 +631,14 @@ begin
FSource.Add(ALine);
end;
procedure TTestParser.Add(const Lines: array of String);
var
i: Integer;
begin
for i:=Low(Lines) to High(Lines) do
Add(Lines[i]);
end;
procedure TTestParser.StartParsing;
var

87
packages/fcl-passrc/tests/tcclasstype.pas
View File

@ -5,7 +5,7 @@ unit tcclasstype;
interface
uses
Classes, SysUtils, fpcunit, pparser, pastree, testregistry, tctypeparser;
Classes, SysUtils, fpcunit, pscanner,pparser, pastree, testregistry, tctypeparser;
type
@ -30,6 +30,7 @@ type
function GetT(AIndex : Integer) : TPasType;
protected
Procedure StartClass (AParent : String = 'TObject'; InterfaceList : String = '');
Procedure StartExternalClass (AParent : String; AExternalName,AExternalNameSpace : String );
Procedure StartClassHelper (ForType : String = 'TOriginal'; AParent : String = 'TObject');
Procedure StartInterface (AParent : String = 'IInterface'; UUID : String = ''; Disp : Boolean = False);
Procedure StartRecordHelper (ForType : String = 'TOriginal'; AParent : String = 'TObject');
@ -91,6 +92,8 @@ type
procedure TestHintFieldExperimental;
procedure TestHintFieldLibraryError;
procedure TestHintFieldUninmplemented;
Procedure TestOneVarFieldExternalName;
procedure TestOneVarFieldExternalNameSemicolon;
Procedure TestMethodSimple;
Procedure TestMethodSimpleComment;
Procedure TestMethodWithDotFails;
@ -141,6 +144,10 @@ type
Procedure TestPropertyReadFromRecordField;
procedure TestPropertyReadFromArrayField;
procedure TestPropertyReadWriteFromRecordField;
Procedure TestExternalClass;
Procedure TestExternalClassNoNameSpace;
Procedure TestExternalClassNoNameKeyWord;
Procedure TestExternalClassNoName;
Procedure TestLocalSimpleType;
Procedure TestLocalSimpleTypes;
Procedure TestLocalSimpleConst;
@ -252,6 +259,21 @@ begin
FParent:=AParent;
end;
procedure TTestClassType.StartExternalClass(AParent: String; AExternalName,
AExternalNameSpace: String);
Var
S : String;
begin
FStarted:=True;
S:=Format('TMyClass = Class external ''%s'' name ''%s'' ',[AExternalNameSpace,AExternalName]);
if (AParent<>'') then
S:=S+'('+AParent+')';
FDecl.Add(S);
FParent:=AParent;
end;
procedure TTestClassType.StartClassHelper(ForType: String; AParent: String);
Var
S : String;
@ -762,6 +784,28 @@ begin
AssertMemberName('unimplemented');
end;
procedure TTestClassType.TestOneVarFieldExternalName;
begin
Parser.CurrentModeswitches:=Parser.CurrentModeswitches+[msExternalClass];
StartExternalClass('','myname','');
AddMember('unimplemented: integer external name ''uni''');
ParseClass;
AssertEquals('1 members',1,TheClass.members.Count);
AssertNotNull('Have field',Field1);
AssertMemberName('unimplemented');
end;
procedure TTestClassType.TestOneVarFieldExternalNameSemicolon;
begin
Parser.CurrentModeswitches:=Parser.CurrentModeswitches+[msExternalClass];
StartExternalClass('','myname','');
AddMember('unimplemented: integer; external name ''uni''');
ParseClass;
AssertEquals('1 members',1,TheClass.members.Count);
AssertNotNull('Have field',Field1);
AssertMemberName('unimplemented');
end;
procedure TTestClassType.TestMethodSimple;
begin
AddMember('Procedure DoSomething');
@ -1142,7 +1186,7 @@ end;
procedure TTestClassType.TestPropertyRedeclareDefault;
begin
StartVisibility(visPublic);
AddMember('Property Something; default;');
AddMember('Property Something; default');
ParseClass;
AssertProperty(Property1,visPublic,'Something','','','','',0,True,False);
AssertNull('No type',Property1.VarType);
@ -1494,6 +1538,45 @@ begin
Assertequals('Default value','',Property1.DefaultValue);
end;
procedure TTestClassType.TestExternalClass;
begin
StartExternalClass('','myname','mynamespace');
Parser.CurrentModeswitches:=[msObjfpc,msexternalClass];
ParseClass;
AssertTrue('External class ',TheClass.IsExternal);
AssertEquals('External name space','mynamespace',TheClass.ExternalNameSpace);
AssertEquals('External name ','myname',TheClass.ExternalName);
end;
procedure TTestClassType.TestExternalClassNoNameSpace;
begin
FStarted:=True;
Parser.CurrentModeswitches:=[msObjfpc,msexternalClass];
FDecl.add('TMyClass = Class external name ''me'' ');
ParseClass;
AssertTrue('External class ',TheClass.IsExternal);
AssertEquals('External name space','',TheClass.ExternalNameSpace);
AssertEquals('External name ','me',TheClass.ExternalName);
end;
procedure TTestClassType.TestExternalClassNoNameKeyWord;
begin
FStarted:=True;
Parser.CurrentModeswitches:=[msObjfpc,msexternalClass];
FDecl.add('TMyClass = Class external ''name'' ''me'' ');
AssertException('No name keyword raises error',EParserError,@ParseClass);
end;
procedure TTestClassType.TestExternalClassNoName;
begin
FStarted:=True;
Parser.CurrentModeswitches:=[msObjfpc,msexternalClass];
FDecl.add('TMyClass = Class external ''name'' name ');
AssertException('No name raises error',EParserError,@ParseClass);
end;
procedure TTestClassType.TestLocalSimpleType;
begin
StartVisibility(visPublic);

19
packages/fcl-passrc/tests/tcexprparser.pas
View File

@ -103,6 +103,7 @@ type
Procedure TestFunctionCall;
Procedure TestFunctionCall2args;
Procedure TestFunctionCallNoArgs;
Procedure ParseStrWithFormatFullyQualified;
Procedure TestRange;
Procedure TestBracketsTotal;
Procedure TestBracketsLeft;
@ -1031,6 +1032,24 @@ begin
AssertNotNull('Have left',AOperand);
end;
Procedure TTestExpressions.ParseStrWithFormatFullyQualified;
Var
P : TParamsExpr;
B : TBinaryExpr;
begin
DeclareVar('string','a');
DeclareVar('integer','i');
ParseExpression('system.str(i:0:3,a)');
B:=TBinaryExpr(AssertExpression('Binary identifier',theExpr,pekBinary,TBinaryExpr));
P:=TParamsExpr(AssertExpression('Simple identifier',B.Right,pekFuncParams,TParamsExpr));
AssertExpression('Name of function',P.Value,pekIdent,'str');
AssertEquals('2 argument',2,Length(p.params));
AssertExpression('Simple identifier',p.params[0],pekIdent,'i');
AssertExpression('Simple identifier',p.params[1],pekIdent,'a');
end;
initialization
RegisterTest(TTestExpressions);

122
packages/fcl-passrc/tests/tcgenerics.pp Normal file
View File

@ -0,0 +1,122 @@
unit tcgenerics;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpcunit, pastree, testregistry, pscanner, pparser, tctypeparser;
Type
{ TTestGenerics }
TTestGenerics = Class(TBaseTestTypeParser)
Published
Procedure TestObjectGenerics;
Procedure TestSpecializationDelphi;
Procedure TestDeclarationDelphi;
Procedure TestDeclarationDelphiSpecialize;
Procedure TestMethodImplementation;
Procedure TestInlineSpecializationInProcedure;
end;
implementation
procedure TTestGenerics.TestObjectGenerics;
begin
Source.Add('Type');
Source.Add('Generic TSomeClass<T> = Object');
Source.Add(' b : T;');
Source.Add('end;');
ParseDeclarations;
end;
procedure TTestGenerics.TestSpecializationDelphi;
begin
ParseType('TFPGList<integer>',TPasClassType,'');
end;
procedure TTestGenerics.TestDeclarationDelphi;
Var
T : TPasClassType;
begin
Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches ;
Source.Add('Type');
Source.Add(' TSomeClass<T,T2> = Class(TObject)');
Source.Add(' b : T;');
Source.Add(' b2 : T2;');
Source.Add('end;');
ParseDeclarations;
AssertNotNull('have generic definition',Declarations.Classes);
AssertEquals('have generic definition',1,Declarations.Classes.Count);
AssertEquals('Pascal class',TPasClassType,TObject(Declarations.Classes[0]).ClassType);
T:=TPasClassType(Declarations.Classes[0]);
AssertNotNull('have generic templates',T.GenericTemplateTypes);
AssertEquals('2 template types',2,T.GenericTemplateTypes.Count);
AssertSame('Parent 0 is class',T,TPasElement(T.GenericTemplateTypes[0]).Parent);
AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent);
end;
procedure TTestGenerics.TestDeclarationDelphiSpecialize;
Var
T : TPasClassType;
begin
Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches ;
Source.Add('Type');
Source.Add(' TSomeClass<T,T2> = Class(TSomeGeneric<Integer,Integer>)');
Source.Add(' b : T;');
Source.Add(' b2 : T2;');
Source.Add('end;');
ParseDeclarations;
AssertNotNull('have generic definition',Declarations.Classes);
AssertEquals('have generic definition',1,Declarations.Classes.Count);
AssertEquals('Pascal class',TPasClassType,TObject(Declarations.Classes[0]).ClassType);
T:=TPasClassType(Declarations.Classes[0]);
AssertEquals('Name is correct','TSomeClass',T.Name);
AssertNotNull('have generic templates',T.GenericTemplateTypes);
AssertEquals('2 template types',2,T.GenericTemplateTypes.Count);
AssertSame('Parent 0 is class',T,TPasElement(T.GenericTemplateTypes[0]).Parent);
AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent);
end;
procedure TTestGenerics.TestMethodImplementation;
begin
With source do
begin
Add('unit afile;');
Add('{$MODE DELPHI}');
Add('interface');
Add('type');
Add(' TTest<T> = object');
Add(' procedure foo(v:T);');
Add(' end;');
Add('implementation');
Add('procedure TTest<T>.foo;');
Add('begin');
Add('end;');
end;
ParseModule;
end;
procedure TTestGenerics.TestInlineSpecializationInProcedure;
begin
With source do
begin
Add('unit afile;');
Add('{$MODE DELPHI}');
Add('interface');
Add('type');
Add(' TFoo=class');
Add(' procedure foo(var Node:TSomeGeneric<TBoundingBox>;const index:Integer);');
Add(' end;');
Add('implementation');
end;
ParseModule;
end;
initialization
RegisterTest(TTestGenerics);
end.

16
packages/fcl-passrc/tests/tcprocfunc.pas
View File

@ -130,6 +130,8 @@ type
Procedure TestFunctionForwardInterface;
Procedure TestProcedureForward;
Procedure TestFunctionForward;
Procedure TestProcedureFar;
Procedure TestFunctionFar;
Procedure TestProcedureCdeclForward;
Procedure TestFunctionCDeclForward;
Procedure TestProcedureCompilerProc;
@ -943,6 +945,20 @@ begin
AssertFunc([pmforward],ccDefault,0);
end;
procedure TTestProcedureFunction.TestProcedureFar;
begin
AddDeclaration('procedure A; far;');
ParseProcedure;
AssertProc([pmfar],ccDefault,0);
end;
procedure TTestProcedureFunction.TestFunctionFar;
begin
AddDeclaration('function A : integer; far;');
ParseFunction;
AssertFunc([pmfar],ccDefault,0);
end;
procedure TTestProcedureFunction.TestProcedureCdeclForward;
begin
UseImplementation:=True;

2150
packages/fcl-passrc/tests/tcresolver.pas
View File

File diff suppressed because it is too large Load Diff

6
packages/fcl-passrc/tests/tcscanner.pas
View File

@ -81,6 +81,7 @@ type
procedure TestNestedComment2;
procedure TestNestedComment3;
procedure TestNestedComment4;
procedure TestNestedComment5;
procedure TestIdentifier;
procedure TestSelf;
procedure TestSelfNoToken;
@ -542,6 +543,11 @@ begin
TestToken(tkComment,'{ (* comment *) }');
end;
procedure TTestScanner.TestNestedComment5;
begin
TestToken(tkComment,'(* (* comment *) *)');
end;
procedure TTestScanner.TestIdentifier;

26
packages/fcl-passrc/tests/tcstatements.pas
View File

@ -110,8 +110,9 @@ Type
Procedure TestTryExceptOn2;
Procedure TestTryExceptOnElse;
Procedure TestTryExceptOnIfElse;
procedure TestTryExceptRaise;
procedure TestTryExceptRaise;
Procedure TestAsm;
Procedure TestGotoInIfThen;
end;
implementation
@ -401,11 +402,11 @@ begin
S:=Statement as TPasImplSimple;
AssertExpression('Doit call',S.Expr,pekBinary,TBinaryExpr);
B:=S.Expr as TBinaryExpr;
AssertExpression('Unit name part 1',B.Left,pekIdent,'Unita');
AssertExpression('Second part of unit name',B.Right,pekBinary,TBinaryExpr);
B:=B.Right as TBinaryExpr;
AssertExpression('Unit name part 2',B.Left,pekIdent,'ClassB');
AssertExpression('Doit call',B.Right,pekIdent,'Doit');
AssertExpression('First two parts of unit name',B.left,pekBinary,TBinaryExpr);
B:=B.left as TBinaryExpr;
AssertExpression('Unit name part 1',B.Left,pekIdent,'Unita');
AssertExpression('Unit name part 2',B.right,pekIdent,'ClassB');
end;
procedure TTestStatementParser.TestCallNoArgs;
@ -1646,6 +1647,21 @@ begin
AssertEquals('token 4 ','1',T.Tokens[3]);
end;
Procedure TTestStatementParser.TestGotoInIfThen;
begin
AddStatements(['if expr then',
' dosomething',
' else if expr2 then',
' goto try_qword',
' else',
' dosomething;',
' try_qword:',
' dosomething;',
'end.']);
ParseModule;
end;
initialization
RegisterTests([TTestStatementParser]);

5
packages/fcl-passrc/tests/tctypeparser.pas
View File

@ -161,7 +161,6 @@ type
Procedure TestReferencePointer;
Procedure TestInvalidColon;
Procedure TestTypeHelper;
Procedure TestSpecializationDelphi;
end;
{ TTestRecordTypeParser }
@ -3306,10 +3305,6 @@ begin
ParseType('Type Helper for AnsiString end',TPasClassType,'');
end;
procedure TTestTypeParser.TestSpecializationDelphi;
begin
ParseType('TFPGList<integer>',TPasClassType,'');
end;
initialization
RegisterTests([TTestTypeParser,TTestRecordTypeParser,TTestProcedureTypeParser]);

1409
packages/fcl-passrc/tests/tcuseanalyzer.pas Normal file
View File

File diff suppressed because it is too large Load Diff

7
packages/fcl-passrc/tests/tcvarparser.pas
View File

@ -44,6 +44,7 @@ Type
Procedure TestVarExternal;
Procedure TestVarExternalLib;
Procedure TestVarExternalLibName;
procedure TestVarExternalNoSemiColon;
Procedure TestVarCVar;
Procedure TestVarCVarExternal;
Procedure TestVarPublic;
@ -269,6 +270,12 @@ begin
AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
end;
procedure TTestVarParser.TestVarExternalNoSemiColon;
begin
ParseVar('integer external','');
AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
end;
procedure TTestVarParser.TestVarExternalLib;
begin
ParseVar('integer; external name ''mylib''','');

31
packages/fcl-passrc/tests/testpassrc.lpi
View File

@ -1,7 +1,7 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<Version Value="10"/>
<General>
<Flags>
<SaveOnlyProjectUnits Value="True"/>
@ -16,9 +16,6 @@
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
@ -30,7 +27,7 @@
<RunParams>
<local>
<FormatVersion Value="1"/>
<CommandLineParams Value="--suite=TTestStatementParser.TestCaseElseNoSemicolon"/>
<CommandLineParams Value="--suite=TTestGenerics.TestInlineSpecializationInProcedure"/>
</local>
</RunParams>
<RequiredPackages Count="1">
@ -38,7 +35,7 @@
<PackageName Value="FCL"/>
</Item1>
</RequiredPackages>
<Units Count="13">
<Units Count="15">
<Unit0>
<Filename Value="testpassrc.lpr"/>
<IsPartOfProject Value="True"/>
@ -91,6 +88,14 @@
<Filename Value="tcresolver.pas"/>
<IsPartOfProject Value="True"/>
</Unit12>
<Unit13>
<Filename Value="tcgenerics.pp"/>
<IsPartOfProject Value="True"/>
</Unit13>
<Unit14>
<Filename Value="tcuseanalyzer.pas"/>
<IsPartOfProject Value="True"/>
</Unit14>
</Units>
</ProjectOptions>
<CompilerOptions>
@ -102,6 +107,20 @@
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="../src"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<AllowLabel Value="False"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
<StackChecks Value="True"/>
</Checks>
<VerifyObjMethodCallValidity Value="True"/>
</CodeGeneration>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">

3
packages/fcl-passrc/tests/testpassrc.lpr
View File

@ -5,7 +5,8 @@ program testpassrc;
uses
Classes, consoletestrunner, tcscanner, tctypeparser, tcstatements,
tcbaseparser, tcmoduleparser, tconstparser, tcvarparser, tcclasstype,
tcexprparser, tcprocfunc, tcpassrcutil, tcresolver;
tcexprparser, tcprocfunc, tcpassrcutil, tcresolver, tcgenerics,
tcuseanalyzer;
type

43
packages/fcl-web/src/base/fpweb.pp
View File

@ -50,13 +50,20 @@ Type
TFPWebActions = Class(TCustomWebActions)
private
FCurrentAction : TCustomWebAction;
FCurrentAction : TFPWebAction;
function GetFPWebActions(Index : Integer): TFPWebAction;
procedure SetFPWebActions(Index : Integer; const AValue: TFPWebAction);
protected
Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse; Var Handled : Boolean); virtual;
Procedure GetContent(ARequest : TRequest; Content : TStream; Var Handled : Boolean); virtual;
Function GetRequestAction(ARequest: TRequest) : TFPWebAction;
Public
Function Add : TFPWebAction;
Function ActionByName(const AName : String) : TFPWebAction;
Function FindAction(const AName : String): TFPWebAction;
Property FPWebActions[Index : Integer] : TFPWebAction Read GetFPWebActions Write SetFPWebActions; Default;
Property ActionVar;
Property CurrentAction: TCustomWebAction read FCurrentAction;
Property CurrentAction: TFPWebAction read FCurrentAction;
end;
{ TTemplateVar }
@ -553,10 +560,40 @@ end;
{ TFPWebActions }
Function TFPWebActions.GetRequestAction(ARequest: TRequest) : TFPWebAction;
begin
Result := inherited GetRequestAction(ARequest) as TFPWebAction;
end;
Function TFPWebActions.Add : TFPWebAction;
begin
Result := inherited Add as TFPWebAction;
end;
Function TFPWebActions.ActionByName(const AName : String) : TFPWebAction;
begin
Result := inherited ActionByName(AName) as TFPWebAction;
end;
Function TFPWebActions.FindAction(const AName : String): TFPWebAction;
begin
Result := inherited FindAction(AName) as TFPWebAction;
end;
function TFPWebActions.GetFPWebActions(Index : Integer): TFPWebAction;
begin
Result := Actions[Index] as TFPWebAction;
end;
procedure TFPWebActions.SetFPWebActions(Index : Integer; const AValue: TFPWebAction);
begin
Actions[Index] := AValue;
end;
procedure TFPWebActions.HandleRequest(ARequest: TRequest; AResponse: TResponse; Var Handled : Boolean);
Var
A : TCustomWebAction;
A : TFPWebAction;
begin
{$ifdef cgidebug}SendMethodEnter('FPWebActions.handlerequest');{$endif cgidebug}

2
packages/pastojs/fpmake.pp
View File

@ -19,7 +19,7 @@ begin
{$endif ALLPACKAGES}
P.Version:='3.0.3';
P.OSes := AllOses;
P.OSes := AllOses-[embedded,msdos,win16];
P.Dependencies.Add('fcl-js');
P.Dependencies.Add('fcl-passrc');

4934
packages/pastojs/src/fppas2js.pp
View File

File diff suppressed because it is too large Load Diff

34
packages/pastojs/tests/tcconverter.pp
View File

@ -187,8 +187,8 @@ begin
R:=TPasImplIfElse.Create('',Nil);
R.ConditionExpr:=CreateCondition;
E:=TJSIfStatement(Convert(R,TJSIfStatement));
AssertEquals('If branch is empty block statement',TJSEmptyBlockStatement,E.btrue.ClassType);
AssertNull('No else branch',E.bfalse);
AssertNull('If branch is empty',E.BTrue);
AssertNull('No else branch',E.BFalse);
AssertIdentifier('Left hand side OK',E.Cond,'a');
end;
@ -388,7 +388,7 @@ begin
// for(i=1; i<=$loopend1; i++){ a:=b; }
// "var $loopend1=100"
LoopEndVar:=DefaultVarNameLoopEnd+'1';
LoopEndVar:=Pas2JSBuiltInNames[pbivnLoopEnd]+'1';
VS:=TJSVariableStatement(AssertElement('First in list is var '+LoopEndVar,TJSVariableStatement,L.A));
VD:=TJSVarDeclaration(AssertElement('var '+LoopEndVar,TJSVarDeclaration,VS.A));
AssertEquals('Correct name for '+LoopEndVar,LoopEndVar,VD.Name);
@ -442,7 +442,7 @@ begin
// for(i=100; i>=$loopend1; i--){ a:=b; }
// "var $loopend1=1"
LoopEndVar:=DefaultVarNameLoopEnd+'1';
LoopEndVar:=Pas2JSBuiltInNames[pbivnLoopEnd]+'1';
VS:=TJSVariableStatement(AssertElement('var '+LoopEndVar,TJSVariableStatement,L.A));
VD:=TJSVarDeclaration(AssertElement('var '+LoopEndVar,TJSVarDeclaration,VS.A));
AssertEquals('Correct name for '+LoopEndVar,LoopEndVar,VD.Name);
@ -646,6 +646,7 @@ Var
ExObj: TJSElement;
VS: TJSVariableStatement;
V: TJSVarDeclaration;
ExceptObjName: String;
begin
// Try a:=B except on E : exception do b:=c end;
@ -668,7 +669,8 @@ begin
// Convert
El:=TJSTryCatchStatement(Convert(T,TJSTryCatchStatement));
// check "catch(exceptobject)"
AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),String(El.Ident));
ExceptObjName:=lowercase(Pas2JSBuiltInNames[pbivnExceptObject]);
AssertEquals('Correct exception object name',ExceptObjName,String(El.Ident));
// check "if"
I:=TJSIfStatement(AssertElement('On block is if',TJSIfStatement,El.BCatch));
// check if condition "exception.isPrototypeOf(exceptobject)"
@ -679,14 +681,14 @@ begin
AssertNotNull('args of exception.isPrototypeOf(exceptobject)',IC.Args);
AssertEquals('args of exception.isPrototypeOf(exceptobject)',1,IC.Args.Elements.Count);
ExObj:=IC.Args.Elements.Elements[0].Expr;
Assertidentifier('arg of exception.isPrototypeOf(exceptobject)',ExObj,lowercase(DefaultJSExceptionObject));
Assertidentifier('arg of exception.isPrototypeOf(exceptobject)',ExObj,ExceptObjName);
// check statement "var e = exceptobject;"
L:=AssertListStatement('On block is always a list',I.BTrue);
writeln('TTestStatementConverter.TestTryExceptStatementOnE ',L.A.ClassName);
VS:=TJSVariableStatement(AssertElement('First statement in list is a var statement',TJSVariableStatement,L.A));
V:=TJSVarDeclaration(AssertElement('var declaration e=ExceptObject',TJSVarDeclaration,VS.A));
AssertEquals('Variable name is identifier in On A : Ex do','e',V.Name);
Assertidentifier('Variable init is exception object',V.Init,lowercase(DefaultJSExceptionObject));
Assertidentifier('Variable init is exception object',V.Init,ExceptObjName);
// check "b = c;"
AssertAssignStatement('Original assignment in second statement',L.B,'b','c');
end;
@ -705,6 +707,7 @@ Var
D: TJSDotMemberExpression;
ExObj: TJSElement;
VS: TJSVariableStatement;
ExceptObjName: String;
begin
// Try a:=B except on E : exception do raise; end;
@ -712,10 +715,10 @@ begin
Becomes:
try {
a=b;
} catch (exceptobject) {
if (exception.isPrototypeOf(exceptobject)) {
var e = exceptobject;
throw exceptobject;
} catch ($e) {
if (exception.isPrototypeOf($e)) {
var e = $e;
throw $e;
}
}
*)
@ -727,7 +730,8 @@ begin
// Convert
El:=TJSTryCatchStatement(Convert(T,TJSTryCatchStatement));
// check "catch(exceptobject)"
AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),String(El.Ident));
ExceptObjName:=lowercase(Pas2JSBuiltInNames[pbivnExceptObject]);
AssertEquals('Correct exception object name',ExceptObjName,String(El.Ident));
// check "if"
I:=TJSIfStatement(AssertElement('On block is if',TJSIfStatement,El.BCatch));
// check if condition "exception.isPrototypeOf(exceptobject)"
@ -738,16 +742,16 @@ begin
AssertNotNull('args of exception.isPrototypeOf(ExceptObject)',IC.Args);
AssertEquals('args of exception.isPrototypeOf(ExceptObject)',1,IC.Args.Elements.Count);
ExObj:=IC.Args.Elements.Elements[0].Expr;
Assertidentifier('arg of exception.isPrototypeOf(ExceptObject)',ExObj,lowercase(DefaultJSExceptionObject));
Assertidentifier('arg of exception.isPrototypeOf(ExceptObject)',ExObj,ExceptObjName);
// check statement "var e = exceptobject;"
L:=AssertListStatement('On block is always a list',I.BTrue);
writeln('TTestStatementConverter.TestTryExceptStatementOnE ',L.A.ClassName);
VS:=TJSVariableStatement(AssertElement('First statement in list is a var statement',TJSVariableStatement,L.A));
V:=TJSVarDeclaration(AssertElement('var declaration e=ExceptObject',TJSVarDeclaration,VS.A));
AssertEquals('Variable name is identifier in On A : Ex do','e',V.Name);
Assertidentifier('Variable init is exception object',V.Init,lowercase(DefaultJSExceptionObject));
Assertidentifier('Variable init is exception object',V.Init,ExceptObjName);
R:=TJSThrowStatement(AssertElement('On block is throw statement',TJSThrowStatement,L.B));
Assertidentifier('R expression is original exception ',R.A,lowercase(DefaultJSExceptionObject));
Assertidentifier('R expression is original exception ',R.A,ExceptObjName);
end;
Procedure TTestStatementConverter.TestVariableStatement;

3696
packages/pastojs/tests/tcmodules.pas
View File

File diff suppressed because it is too large Load Diff

762
packages/pastojs/tests/tcoptimizations.pas Normal file
View File

@ -0,0 +1,762 @@
{
This file is part of the Free Component Library (FCL)
Copyright (c) 2017 by Michael Van Canneyt
Unit tests for Pascal-to-Javascript converter class.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************
Examples:
./testpas2js --suite=TTestOptimizations
./testpas2js --suite=TTestOptimizations.TestOmitLocalVar
}
unit tcoptimizations;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpcunit, testregistry, fppas2js, pastree,
PScanner, PasUseAnalyzer, PasResolver,
tcmodules;
type
{ TCustomTestOptimizations }
TCustomTestOptimizations = class(TCustomTestModule)
private
FAnalyzerModule: TPasAnalyzer;
FAnalyzerProgram: TPasAnalyzer;
FWholeProgramOptimization: boolean;
function OnConverterIsElementUsed(Sender: TObject; El: TPasElement
): boolean;
protected
procedure SetUp; override;
procedure TearDown; override;
procedure ParseModule; override;
procedure ParseProgram; override;
public
property AnalyzerModule: TPasAnalyzer read FAnalyzerModule;
property AnalyzerProgram: TPasAnalyzer read FAnalyzerProgram;
property WholeProgramOptimization: boolean read FWholeProgramOptimization
write FWholeProgramOptimization;
end;
{ TTestOptimizations }
TTestOptimizations = class(TCustomTestOptimizations)
published
// Whole Program Optimization
procedure TestWPO_OmitLocalVar;
procedure TestWPO_OmitLocalProc;
procedure TestWPO_OmitLocalProcForward;
procedure TestWPO_OmitProcLocalVar;
procedure TestWPO_OmitProcLocalConst;
procedure TestWPO_OmitProcLocalType;
procedure TestWPO_OmitProcLocalProc;
procedure TestWPO_OmitProcLocalForwardProc;
procedure TestWPO_OmitRecordMember;
procedure TestWPO_OmitNotUsedTObject;
procedure TestWPO_TObject;
procedure TestWPO_OmitClassField;
procedure TestWPO_OmitClassMethod;
procedure TestWPO_OmitClassClassMethod;
procedure TestWPO_OmitPropertyGetter1;
procedure TestWPO_OmitPropertyGetter2;
procedure TestWPO_OmitPropertySetter1;
procedure TestWPO_OmitPropertySetter2;
procedure TestWPO_CallInherited;
procedure TestWPO_UseUnit;
procedure TestWPO_ProgramPublicDeclaration;
end;
implementation
{ TCustomTestOptimizations }
function TCustomTestOptimizations.OnConverterIsElementUsed(Sender: TObject;
El: TPasElement): boolean;
var
A: TPasAnalyzer;
begin
if WholeProgramOptimization then
A:=AnalyzerProgram
else
A:=AnalyzerModule;
Result:=A.IsUsed(El);
{$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
writeln('TCustomTestOptimizations.OnConverterIsElementUsed El=',GetObjName(El),' WPO=',WholeProgramOptimization,' Result=',Result);
{$ENDIF}
end;
procedure TCustomTestOptimizations.SetUp;
begin
inherited SetUp;
FWholeProgramOptimization:=false;
FAnalyzerModule:=TPasAnalyzer.Create;
FAnalyzerModule.Resolver:=Engine;
FAnalyzerProgram:=TPasAnalyzer.Create;
FAnalyzerProgram.Resolver:=Engine;
Converter.OnIsElementUsed:=@OnConverterIsElementUsed;
end;
procedure TCustomTestOptimizations.TearDown;
begin
FreeAndNil(FAnalyzerProgram);
FreeAndNil(FAnalyzerModule);
inherited TearDown;
end;
procedure TCustomTestOptimizations.ParseModule;
begin
inherited ParseModule;
{$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
writeln('TCustomTestOptimizations.ParseModule START');
{$ENDIF}
AnalyzerModule.AnalyzeModule(Module);
{$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
writeln('TCustomTestOptimizations.ParseModule END');
{$ENDIF}
end;
procedure TCustomTestOptimizations.ParseProgram;
begin
WholeProgramOptimization:=true;
inherited ParseProgram;
{$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
writeln('TCustomTestOptimizations.ParseProgram START');
{$ENDIF}
AnalyzerProgram.AnalyzeWholeProgram(Module as TPasProgram);
{$IF defined(VerbosePas2JS) or defined(VerbosePasAnalyzer)}
writeln('TCustomTestOptimizations.ParseProgram START');
{$ENDIF}
end;
{ TTestOptimizations }
procedure TTestOptimizations.TestWPO_OmitLocalVar;
begin
StartProgram(false);
Add('var');
Add(' a: longint;');
Add(' b: longint;');
Add('begin');
Add(' b:=3;');
ConvertProgram;
CheckSource('TestWPO_OmitLocalVar',
'this.b = 0;',
'this.b = 3;');
end;
procedure TTestOptimizations.TestWPO_OmitLocalProc;
begin
StartProgram(false);
Add('procedure DoIt; begin end;');
Add('procedure NoIt; begin end;');
Add('begin');
Add(' DoIt;');
ConvertProgram;
CheckSource('TestWPO_OmitLocalProc',
LinesToStr([
'this.DoIt = function () {',
'};',
'']),
LinesToStr([
'this.DoIt();',
'']));
end;
procedure TTestOptimizations.TestWPO_OmitLocalProcForward;
begin
StartProgram(false);
Add('procedure DoIt; forward;');
Add('procedure NoIt; forward;');
Add('procedure DoIt; begin end;');
Add('procedure NoIt; begin end;');
Add('begin');
Add(' DoIt;');
ConvertProgram;
CheckSource('TestWPO_OmitLocalProcForward',
LinesToStr([
'this.DoIt = function () {',
'};',
'']),
LinesToStr([
'this.DoIt();',
'']));
end;
procedure TTestOptimizations.TestWPO_OmitProcLocalVar;
begin
StartProgram(false);
Add('function DoIt: longint;');
Add('var');
Add(' a: longint;');
Add(' b: longint;');
Add('begin');
Add(' b:=3;');
Add(' Result:=b;');
Add('end;');
Add('begin');
Add(' DoIt;');
ConvertProgram;
CheckSource('TestWPO_OmitProcLocalVar',
LinesToStr([
'this.DoIt = function () {',
' var Result = 0;',
' var b = 0;',
' b = 3;',
' Result = b;',
' return Result;',
'};',
'']),
LinesToStr([
'this.DoIt();',
'']));
end;
procedure TTestOptimizations.TestWPO_OmitProcLocalConst;
begin
StartProgram(false);
Add('function DoIt: longint;');
Add('const');
Add(' a = 3;');
Add(' b = 4;');
Add(' c: longint = 5;');
Add(' d: longint = 6;');
Add('begin');
Add(' Result:=b+d;');
Add('end;');
Add('begin');
Add(' DoIt;');
ConvertProgram;
CheckSource('TestWPO_OmitProcLocalConst',
LinesToStr([
'var b = 4;',
'var d = 6;',
'this.DoIt = function () {',
' var Result = 0;',
' Result = b + d;',
' return Result;',
'};',
'']),
LinesToStr([
'this.DoIt();',
'']));
end;
procedure TTestOptimizations.TestWPO_OmitProcLocalType;
begin
StartProgram(false);
Add('function DoIt: longint;');
Add('type');
Add(' TEnum = (red, green);');
Add(' TEnums = set of TEnum;');
Add('begin');
Add(' Result:=3;');
Add('end;');
Add('begin');
Add(' DoIt;');
ConvertProgram;
CheckSource('TestWPO_OmitProcLocalType',
LinesToStr([
'this.DoIt = function () {',
' var Result = 0;',
' Result = 3;',
' return Result;',
'};',
'']),
LinesToStr([
'this.DoIt();',
'']));
end;
procedure TTestOptimizations.TestWPO_OmitProcLocalProc;
begin
StartProgram(false);
Add('procedure DoIt;');
Add(' procedure SubProcA; begin end;');
Add(' procedure SubProcB; begin end;');
Add('begin');
Add(' SubProcB;');
Add('end;');
Add('begin');
Add(' DoIt;');
ConvertProgram;
CheckSource('TestWPO_OmitProcLocalProc',
LinesToStr([
'this.DoIt = function () {',
' function SubProcB() {',
' };',
' SubProcB();',
'};',
'']),
LinesToStr([
'this.DoIt();',
'']));
end;
procedure TTestOptimizations.TestWPO_OmitProcLocalForwardProc;
begin
StartProgram(false);
Add('procedure DoIt;');
Add(' procedure SubProcA; forward;');
Add(' procedure SubProcB; forward;');
Add(' procedure SubProcA; begin end;');
Add(' procedure SubProcB; begin end;');
Add('begin');
Add(' SubProcB;');
Add('end;');
Add('begin');
Add(' DoIt;');
ConvertProgram;
CheckSource('TestWPO_OmitProcLocalForwardProc',
LinesToStr([
'this.DoIt = function () {',
' function SubProcB() {',
' };',
' SubProcB();',
'};',
'']),
LinesToStr([
'this.DoIt();',
'']));
end;
procedure TTestOptimizations.TestWPO_OmitRecordMember;
begin
StartProgram(false);
Add('type');
Add(' TRec = record');
Add(' a: longint;');
Add(' b: longint;');
Add(' end;');
Add('var r: TRec;');
Add('begin');
Add(' r.a:=3;');
ConvertProgram;
CheckSource('TestWPO_OmitRecordMember',
LinesToStr([
'this.TRec = function (s) {',
' if (s) {',
' this.a = s.a;',
' } else {',
' this.a = 0;',
' };',
' this.$equal = function (b) {',
' return this.a == b.a;',
' };',
'};',
'this.r = new this.TRec();',
'']),
LinesToStr([
'this.r.a = 3;',
'']));
end;
procedure TTestOptimizations.TestWPO_OmitNotUsedTObject;
begin
StartProgram(false);
Add('type');
Add(' TObject = class end;');
Add('var o: TObject;');
Add('begin');
ConvertProgram;
CheckSource('TestWPO_OmitNotUsedTObject',
LinesToStr([
'']),
LinesToStr([
'']));
end;
procedure TTestOptimizations.TestWPO_TObject;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' procedure AfterConstruction; virtual;');
Add(' procedure BeforeDestruction; virtual;');
Add(' end;');
Add('procedure TObject.AfterConstruction; begin end;');
Add('procedure TObject.BeforeDestruction; begin end;');
Add('var o: TObject;');
Add('begin');
Add(' o:=nil;');
ConvertProgram;
CheckSource('TestWPO_TObject',
LinesToStr([
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.AfterConstruction = function () {',
' };',
' this.BeforeDestruction = function () {',
' };',
'});',
'this.o = null;',
'']),
LinesToStr([
'this.o = null;']));
end;
procedure TTestOptimizations.TestWPO_OmitClassField;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' a: longint;');
Add(' b: longint;');
Add(' end;');
Add('var o: TObject;');
Add('begin');
Add(' o.a:=3;');
ConvertProgram;
CheckSource('TestWPO_OmitClassField',
LinesToStr([
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' this.a = 0;',
' };',
' this.$final = function () {',
' };',
'});',
'this.o = null;',
'']),
LinesToStr([
'this.o.a = 3;']));
end;
procedure TTestOptimizations.TestWPO_OmitClassMethod;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' procedure ProcA;');
Add(' procedure ProcB;');
Add(' end;');
Add('procedure TObject.ProcA; begin end;');
Add('procedure TObject.ProcB; begin end;');
Add('var o: TObject;');
Add('begin');
Add(' o.ProcB;');
ConvertProgram;
CheckSource('TestWPO_OmitClassMethod',
LinesToStr([
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.ProcB = function () {',
' };',
'});',
'this.o = null;',
'']),
LinesToStr([
'this.o.ProcB();']));
end;
procedure TTestOptimizations.TestWPO_OmitClassClassMethod;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' class procedure ProcA;');
Add(' class procedure ProcB;');
Add(' end;');
Add('class procedure TObject.ProcA; begin end;');
Add('class procedure TObject.ProcB; begin end;');
Add('var o: TObject;');
Add('begin');
Add(' o.ProcB;');
ConvertProgram;
CheckSource('TestWPO_OmitClassMethod',
LinesToStr([
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.ProcB = function () {',
' };',
'});',
'this.o = null;',
'']),
LinesToStr([
'this.o.$class.ProcB();']));
end;
procedure TTestOptimizations.TestWPO_OmitPropertyGetter1;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' FFoo: boolean;');
Add(' function GetFoo: boolean;');
Add(' property Foo: boolean read FFoo;');
Add(' property Foo2: boolean read GetFoo;');
Add(' FBar: boolean;');
Add(' function GetBar: boolean;');
Add(' property Bar: boolean read FBar;');
Add(' property Bar2: boolean read GetBar;');
Add(' end;');
Add('function TObject.GetFoo: boolean; begin Result:=FFoo; end;');
Add('function TObject.GetBar: boolean; begin Result:=FBar; end;');
Add('var o: TObject;');
Add('begin');
Add(' if o.Foo then;');
ConvertProgram;
CheckSource('TestWPO_OmitClassPropertyGetter1',
LinesToStr([
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' this.FFoo = false;',
' };',
' this.$final = function () {',
' };',
'});',
'this.o = null;',
'']),
LinesToStr([
'if (this.o.FFoo);',
'']));
end;
procedure TTestOptimizations.TestWPO_OmitPropertyGetter2;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' FFoo: boolean;');
Add(' function GetFoo: boolean;');
Add(' property Foo: boolean read FFoo;');
Add(' property Foo2: boolean read GetFoo;');
Add(' end;');
Add('function TObject.GetFoo: boolean; begin Result:=FFoo; end;');
Add('var o: TObject;');
Add('begin');
Add(' if o.Foo2 then;');
ConvertProgram;
CheckSource('TestWPO_OmitClassPropertyGetter2',
LinesToStr([
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' this.FFoo = false;',
' };',
' this.$final = function () {',
' };',
' this.GetFoo = function () {',
' var Result = false;',
' Result = this.FFoo;',
' return Result;',
' };',
'});',
'this.o = null;',
'']),
LinesToStr([
'if (this.o.GetFoo()) ;',
'']));
end;
procedure TTestOptimizations.TestWPO_OmitPropertySetter1;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' FFoo: boolean;');
Add(' procedure SetFoo(Value: boolean);');
Add(' property Foo: boolean write FFoo;');
Add(' property Foo2: boolean write SetFoo;');
Add(' FBar: boolean;');
Add(' procedure SetBar(Value: boolean);');
Add(' property Bar: boolean write FBar;');
Add(' property Bar2: boolean write SetBar;');
Add(' end;');
Add('procedure TObject.SetFoo(Value: boolean); begin FFoo:=Value; end;');
Add('procedure TObject.SetBar(Value: boolean); begin FBar:=Value; end;');
Add('var o: TObject;');
Add('begin');
Add(' o.Foo:=true;');
ConvertProgram;
CheckSource('TestWPO_OmitClassPropertySetter1',
LinesToStr([
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' this.FFoo = false;',
' };',
' this.$final = function () {',
' };',
'});',
'this.o = null;',
'']),
LinesToStr([
'this.o.FFoo = true;',
'']));
end;
procedure TTestOptimizations.TestWPO_OmitPropertySetter2;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' FFoo: boolean;');
Add(' procedure SetFoo(Value: boolean);');
Add(' property Foo: boolean write FFoo;');
Add(' property Foo2: boolean write SetFoo;');
Add(' end;');
Add('procedure TObject.SetFoo(Value: boolean); begin FFoo:=Value; end;');
Add('var o: TObject;');
Add('begin');
Add(' o.Foo2:=true;');
ConvertProgram;
CheckSource('TestWPO_OmitClassPropertySetter2',
LinesToStr([
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' this.FFoo = false;',
' };',
' this.$final = function () {',
' };',
' this.SetFoo = function (Value) {',
' this.FFoo = Value;',
' };',
'});',
'this.o = null;',
'']),
LinesToStr([
'this.o.SetFoo(true);',
'']));
end;
procedure TTestOptimizations.TestWPO_CallInherited;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' procedure DoA;');
Add(' procedure DoB;');
Add(' end;');
Add(' TMobile = class');
Add(' procedure DoA;');
Add(' procedure DoC;');
Add(' end;');
Add('procedure TObject.DoA; begin end;');
Add('procedure TObject.DoB; begin end;');
Add('procedure TMobile.DoA;');
Add('begin');
Add(' inherited;');
Add('end;');
Add('procedure TMobile.DoC;');
Add('begin');
Add(' inherited DoB;');
Add('end;');
Add('var o: TMobile;');
Add('begin');
Add(' o.DoA;');
Add(' o.DoC;');
ConvertProgram;
CheckSource('TestWPO_CallInherited',
LinesToStr([
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.DoA = function () {',
' };',
' this.DoB = function () {',
' };',
'});',
' rtl.createClass(this, "TMobile", this.TObject, function () {',
' this.DoA$1 = function () {',
' pas.program.TObject.DoA.apply(this, arguments);',
' };',
' this.DoC = function () {',
' pas.program.TObject.DoB.call(this);',
' };',
'});',
'this.o = null;',
'']),
LinesToStr([
'this.o.DoA$1();',
'this.o.DoC();',
'']));
end;
procedure TTestOptimizations.TestWPO_UseUnit;
var
ActualSrc, ExpectedSrc: String;
begin
AddModuleWithIntfImplSrc('unit1.pp',
LinesToStr([
'var i: longint;',
'procedure DoIt;',
'']),
LinesToStr([
'procedure DoIt; begin end;']));
AddModuleWithIntfImplSrc('unit2.pp',
LinesToStr([
'var j: longint;',
'procedure DoMore;',
'']),
LinesToStr([
'procedure DoMore; begin end;']));
StartProgram(true);
Add('uses unit2;');
Add('begin');
Add(' j:=3;');
ConvertProgram;
ActualSrc:=JSToStr(JSModule);
ExpectedSrc:=LinesToStr([
'rtl.module("program", ["system", "unit2"], function () {',
' this.$main = function () {',
' pas.unit2.j = 3;',
' };',
'});',
'']);
CheckDiff('TestWPO_UseUnit',ExpectedSrc,ActualSrc);
end;
procedure TTestOptimizations.TestWPO_ProgramPublicDeclaration;
var
ActualSrc, ExpectedSrc: String;
begin
StartProgram(true);
Add('var');
Add(' vPublic: longint; public;');
Add(' vPrivate: longint;');
Add('procedure DoPublic; public; begin end;');
Add('procedure DoPrivate; begin end;');
Add('begin');
ConvertProgram;
ActualSrc:=JSToStr(JSModule);
ExpectedSrc:=LinesToStr([
'rtl.module("program", ["system"], function () {',
' this.vPublic = 0;',
' this.DoPublic =function(){',
' };',
' this.$main = function () {',
' };',
'});',
'']);
CheckDiff('TestWPO_ProgramPublicDeclaration',ExpectedSrc,ActualSrc);
end;
Initialization
RegisterTests([TTestOptimizations]);
end.

36
packages/pastojs/tests/testpas2js.lpi
View File

@ -1,7 +1,7 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<Version Value="10"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
@ -12,9 +12,6 @@
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
@ -34,7 +31,7 @@
<PackageName Value="FCL"/>
</Item2>
</RequiredPackages>
<Units Count="3">
<Units Count="5">
<Unit0>
<Filename Value="testpas2js.pp"/>
<IsPartOfProject Value="True"/>
@ -47,14 +44,41 @@
<Filename Value="../src/fppas2js.pp"/>
<IsPartOfProject Value="True"/>
</Unit2>
<Unit3>
<Filename Value="tcmodules.pas"/>
<IsPartOfProject Value="True"/>
</Unit3>
<Unit4>
<Filename Value="tcoptimizations.pas"/>
<IsPartOfProject Value="True"/>
</Unit4>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="testpas2js"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="../src"/>
<OtherUnitFiles Value="../src;../../fcl-js/src;../../fcl-passrc/src;../../pastojs/tests"/>
<UnitOutputDirectory Value="lib"/>
</SearchPaths>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
<StackChecks Value="True"/>
</Checks>
<VerifyObjMethodCallValidity Value="True"/>
</CodeGeneration>
<Other>
<CustomOptions Value="-dVerbosePas2JS"/>
<OtherDefines Count="1">
<Define0 Value="VerbosePas2JS"/>
</OtherDefines>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">

2
packages/pastojs/tests/testpas2js.pp
View File

@ -17,7 +17,7 @@ program testpas2js;
{$mode objfpc}{$H+}
uses
Classes, consoletestrunner, tcconverter, tcmodules;
Classes, consoletestrunner, tcconverter, tcmodules, tcoptimizations;
type

6
utils/pas2js/dist/rtl.js vendored
View File

@ -1,4 +1,4 @@
/*
/*
This file is part of the Free Pascal pas2js tool.
Copyright (c) 2017 Mattias Gaertner
@ -17,7 +17,7 @@ var pas = {};
var rtl = {
quiet: false,
debug_load_units: true,
debug_load_units: false,
m_loading: 0,
m_loading_intf: 1,
@ -27,7 +27,7 @@ var rtl = {
m_initialized: 5,
debug: function(){
if (!window.console || rtl.quiet) return;
if (rtl.quiet || !console || !console.log) return;
console.log(arguments);
},