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

* Patch from Mattias Gaertner:

Browse Source 
pastree: 
    - allow custom data to be chained.
  pparser:
    - procedure modifier assembler
    - Self[]
    - Self.member
    - fixed some wrong parents
  pasresolver:
    - aString[i]:=
    - check proc external modifier
    - test if WithExprScope is set
    - Self[]
    - Self.member
  fppas2js:
    - proc assembler modifier
    - assigned(class-instance)
    - class default property
    - low(array), high(array)
    - multi dim arrays [index1,index2] -> [index1][index2]
    - string: read and write char aString[]
    - procedure modifier external name 'funcname'
    - option to add "use strict";
    - with-do using local var
    - with record do i:=v;
    - with classinstance do begin create; i:=v; f(); i:=a[]; end;
    - Self[]
    - Self.member

git-svn-id: trunk@35428 -
This commit is contained in:
michael 2017-02-12 15:16:00 +00:00
parent 09f415dc81
commit bc22805000
8 changed files with 1477 additions and 250 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
packages/fcl-js/src/jstree.pp
View File

@ -457,7 +457,7 @@ Type
TJSVariableDeclarationList = Class(TJSBinary); // A->first variable, B->next in list, chained.
{ TJSWithStatement }
{ TJSWithStatement - with(A)do B; }
TJSWithStatement = Class(TJSBinary); // A-> with expression, B->statement(s)

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

@ -460,14 +460,13 @@ type
{ TResolveData - base class for data stored in TPasElement.CustomData }
TResolveData = Class
TResolveData = Class(TPasElementBase)
private
FElement: TPasElement;
procedure SetElement(AValue: TPasElement);
public
Owner: TObject; // e.g. a TPasResolver
Next: TResolveData; // TPasResolver uses this for its memory chain
CustomData: TObject; // not used by TPasResolver, free for your extension
constructor Create; virtual;
destructor Destroy; override;
property Element: TPasElement read FElement write SetElement;// Element.CustomData=Self
@ -783,7 +782,8 @@ type
TPasResolverResultFlag = (
rrfReadable,
rrfWritable
rrfWritable,
rrfAssignable // not writable in general, e.g. aString[1]:=
);
TPasResolverResultFlags = set of TPasResolverResultFlag;
@ -2793,9 +2793,15 @@ begin
end;
// finish non method, i.e. interface/implementation/nested procedure/method declaration
if not IsValidIdent(ProcName) then
RaiseNotYetImplemented(20160922163407,El);
if Proc.LibraryExpr<>nil then
ResolveExpr(Proc.LibraryExpr);
if Proc.LibrarySymbolName<>nil then
ResolveExpr(Proc.LibrarySymbolName);
if Proc.Parent is TPasClassType then
begin
FinishMethodDeclHeader(Proc);
@ -2957,6 +2963,11 @@ var
SelfArg: TPasArgument;
p: Integer;
begin
if ImplProc.IsExternal then
RaiseMsg(nInvalidProcModifiers,sInvalidProcModifiers,[ImplProc.ElementTypeName,'external'],ImplProc);
if ImplProc.IsExported then
RaiseMsg(nInvalidProcModifiers,sInvalidProcModifiers,[ImplProc.ElementTypeName,'export'],ImplProc);
ProcName:=ImplProc.Name;
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishMethodBodyHeader searching declaration "',ProcName,'" ...');
@ -4254,6 +4265,8 @@ begin
// found compatible element -> create reference
Ref:=CreateReference(FindCallData.Found,Params.Value);
if FindCallData.StartScope.ClassType=TPasWithExprScope then
Ref.WithExprScope:=TPasWithExprScope(FindCallData.StartScope);
FindData:=Default(TPRFindData);
FindData.ErrorPosEl:=Params.Value;
FindData.StartScope:=FindCallData.StartScope;
@ -4288,41 +4301,48 @@ var
FindData: TPRFindData;
DeclEl: TPasElement;
ResolvedEl, ResolvedArg: TPasResolverResult;
ArgExp: TPasExpr;
ArgExp, Value: TPasExpr;
Ref: TResolvedReference;
PropEl: TPasProperty;
ClassScope: TPasClassScope;
SubParams: TParamsExpr;
begin
DeclEl:=nil;
if (Params.Value.ClassType=TPrimitiveExpr)
and (TPrimitiveExpr(Params.Value).Kind=pekIdent) then
Value:=Params.Value;
if (Value.ClassType=TPrimitiveExpr)
and (TPrimitiveExpr(Value).Kind=pekIdent) then
begin
// e.g. Name[]
ArrayName:=TPrimitiveExpr(Params.Value).Value;
ArrayName:=TPrimitiveExpr(Value).Value;
// find first
DeclEl:=FindElementWithoutParams(ArrayName,FindData,Params.Value,true);
DeclEl:=FindElementWithoutParams(ArrayName,FindData,Value,true);
Ref:=CreateReference(DeclEl,Params.Value,@FindData);
CheckFoundElement(FindData,Ref);
ComputeElement(Params.Value,ResolvedEl,[rcSkipTypeAlias,rcReturnFuncResult]);
ComputeElement(Value,ResolvedEl,[rcSkipTypeAlias,rcReturnFuncResult]);
end
else if Params.Value.ClassType=TParamsExpr then
else if (Value.ClassType=TSelfExpr) then
begin
// e.g. Self[]
ResolveNameExpr(Value,'Self');
ComputeElement(Value,ResolvedEl,[rcSkipTypeAlias,rcReturnFuncResult]);
end
else if Value.ClassType=TParamsExpr then
begin
// e.g. Name()[] or Name[][]
SubParams:=TParamsExpr(Params.Value);
SubParams:=TParamsExpr(Value);
if (SubParams.Kind in [pekArrayParams,pekFuncParams]) then
begin
ResolveExpr(SubParams);
ComputeElement(SubParams,ResolvedEl,[rcSkipTypeAlias,rcReturnFuncResult]);
end
else
RaiseNotYetImplemented(20161010194925,Params.Value);
RaiseNotYetImplemented(20161010194925,Value);
end
else
RaiseNotYetImplemented(20160927212610,Params.Value);
RaiseNotYetImplemented(20160927212610,Value);
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveArrayParamsExpr Params.Value=',GetObjName(Params.Value),' ',GetResolverResultDesc(ResolvedEl));
writeln('TPasResolver.ResolveArrayParamsExpr Value=',GetObjName(Value),' ',GetResolverResultDesc(ResolvedEl));
{$ENDIF}
if ResolvedEl.BaseType in btAllStrings then
begin
@ -5236,9 +5256,10 @@ begin
ResolvedEl.BaseType:=btWideChar
else
ResolvedEl.BaseType:=btChar;
ResolvedEl.IdentEl:=nil;
// keep ResolvedEl.IdentEl the string var
ResolvedEl.TypeEl:=FBaseTypes[ResolvedEl.BaseType];
ResolvedEl.ExprEl:=Params;
ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable]+[rrfAssignable];
end
else if (ResolvedEl.IdentEl is TPasProperty)
and (TPasProperty(ResolvedEl.IdentEl).Args.Count>0) then
@ -6187,7 +6208,7 @@ begin
inherited Create;
FDefaultScope:=TPasDefaultScope.Create;
FPendingForwards:=TFPList.Create;
FBaseTypeStringIndex:=btComp;
FBaseTypeStringIndex:=btChar;
PushScope(FDefaultScope);
end;
@ -7281,7 +7302,7 @@ begin
end;
exit;
end;
if (rrfWritable in ResolvedEl.Flags) then
if [rrfWritable,rrfAssignable]*ResolvedEl.Flags<>[] then
exit(true);
// not writable
if not ErrorOnFalse then exit;

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

@ -82,9 +82,17 @@ type
// Visitor pattern.
TPassTreeVisitor = class;
{ TPasElementBase }
TPasElementBase = class
procedure Accept(Visitor: TPassTreeVisitor); virtual; abstract;
private
FData: TObject;
protected
procedure Accept(Visitor: TPassTreeVisitor); virtual;
public
Property CustomData : TObject Read FData Write FData;
end;
TPasElementBaseClass = class of TPasElementBase;
TPasModule = class;
@ -109,7 +117,6 @@ type
TPasElement = class(TPasElementBase)
private
FData: TObject;
FDocComment: String;
FRefCount: LongWord;
FName: string;
@ -145,7 +152,6 @@ type
property Name: string read FName write FName;
property Parent: TPasElement read FParent Write FParent;
Property Hints : TPasMemberHints Read FHints Write FHints;
Property CustomData : TObject Read FData Write FData;
Property HintMessage : String Read FHintMessage Write FHintMessage;
Property DocComment : String Read FDocComment Write FDocComment;
end;
@ -1313,17 +1319,20 @@ Type
ExceptAddr : TPasExpr;
end;
{ TPassTreeVisitor }
TPassTreeVisitor = class
procedure Visit(obj: TPasElement); virtual;
end;
{ TPasImplLabelMark }
TPasImplLabelMark = class(TPasImplElement)
public
LabelId: AnsiString;
end;
{ TPassTreeVisitor }
TPassTreeVisitor = class
public
procedure Visit(obj: TPasElement); virtual;
end;
const
AccessNames: array[TArgumentAccess] of string[9] = ('', 'const ', 'var ', 'out ','constref ');
AllVisibilities: TPasMemberVisibilities =
@ -1408,6 +1417,13 @@ begin
El:=nil;
end;
{ TPasElementBase }
procedure TPasElementBase.Accept(Visitor: TPassTreeVisitor);
begin
end;
{ TPasTypeRef }
procedure TPasTypeRef.ForEachCall(const aMethodCall: TOnForEachPasElement;

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

@ -367,6 +367,7 @@ type
procedure ParseStatement(Parent: TPasImplBlock; out NewImplElement: TPasImplElement);
procedure ParseLabels(AParent: TPasElement);
procedure ParseProcBeginBlock(Parent: TProcedureBody);
procedure ParseProcAsmBlock(Parent: TProcedureBody);
// Function/Procedure declaration
function ParseProcedureOrFunctionDecl(Parent: TPasElement; ProcType: TProcType;AVisibility : TPasMemberVisibility = VisDefault): TPasProcedure;
procedure ParseArgList(Parent: TPasElement;
@ -1447,10 +1448,12 @@ var
begin
Result:=nil;
if paramskind in [pekArrayParams, pekSet] then begin
if CurToken<>tkSquaredBraceOpen then Exit;
if CurToken<>tkSquaredBraceOpen then
ParseExc(nParserExpectTokenError,SParserExpectTokenError,['[']);
PClose:=tkSquaredBraceClose;
end else begin
if CurToken<>tkBraceOpen then Exit;
if CurToken<>tkBraceOpen then
ParseExc(nParserExpectTokenError,SParserExpectTokenError,['(']);
PClose:=tkBraceClose;
end;
@ -1461,11 +1464,12 @@ begin
if not isEndOfExp then begin
repeat
p:=DoParseExpression(params);
if not Assigned(p) then Exit; // bad param syntax
if not Assigned(p) then
ParseExcSyntaxError;
params.AddParam(p);
if (CurToken=tkColon) then
if Not AllowFormatting then
ParseExcSyntaxError
ParseExc(nParserExpectTokenError,SParserExpectTokenError,[','])
else
begin
NextToken;
@ -1476,15 +1480,14 @@ begin
p.format2:=DoParseExpression(p);
end;
end;
if not (CurToken in [tkComma, PClose]) then begin
Exit;
end;
if not (CurToken in [tkComma, PClose]) then
ParseExc(nParserExpectTokenError,SParserExpectTokenError,[',']);
if CurToken = tkComma then begin
NextToken;
if CurToken = PClose then begin
//ErrorExpected(parser, 'identifier');
Exit;
ParseExcSyntaxError;
end;
end;
until CurToken=PClose;
@ -1573,18 +1576,15 @@ begin
b:=CreateBinaryExpr(AParent,Last, DoParseExpression(AParent), eopNone);
if not Assigned(b.right) then
begin
B.Release;
Exit; // error
b.Release;
ParseExcExpectedIdentifier;
end;
Last:=b;
UngetToken;
end
else
UngetToken;
end;
UngetToken;
end;
tkself:
begin
//Last:=CreatePrimitiveExpr(AParent,pekString, CurTokenText); //function(self);
Last:=CreateSelfExpr(AParent);
NextToken;
if CurToken = tkDot then
@ -1594,8 +1594,8 @@ begin
b:=CreateBinaryExpr(AParent,Last, ParseExpIdent(AParent), TokenToExprOp(optk));
if not Assigned(b.right) then
begin
B.Release;
Exit; // error
b.Release;
ParseExcExpectedIdentifier;
end;
Last:=b;
end;
@ -1633,7 +1633,7 @@ begin
ok:=false;
try
if Last.Kind=pekIdent then
if Last.Kind in [pekIdent,pekSelf] then
begin
while CurToken in [tkDot] do
begin
@ -1906,10 +1906,12 @@ end;
function GetExprIdent(p: TPasExpr): String;
begin
if Assigned(p) and (p is TPrimitiveExpr) and (p.Kind=pekIdent) then
Result:='';
if not Assigned(p) then exit;
if (p.ClassType=TPrimitiveExpr) and (p.Kind=pekIdent) then
Result:=TPrimitiveExpr(p).Value
else
Result:='';
else if (p.ClassType=TSelfExpr) then
Result:='Self';
end;
function TPasParser.DoParseConstValueExpression(AParent: TPasElement): TPasExpr;
@ -2353,6 +2355,7 @@ var
PT : TProcType;
NamePos: TPasSourcePos;
ok: Boolean;
Proc: TPasProcedure;
begin
CurBlock := declNone;
@ -2586,6 +2589,9 @@ begin
begin
if Declarations is TProcedureBody then
begin
Proc:=Declarations.Parent as TPasProcedure;
if pmAssembler in Proc.Modifiers then
ParseExc(nParserExpectTokenError,SParserExpectTokenError,['asm']);
SetBlock(declNone);
ParseProcBeginBlock(TProcedureBody(Declarations));
break;
@ -2600,6 +2606,20 @@ begin
else
ParseExcSyntaxError;
end;
tkasm:
begin
if Declarations is TProcedureBody then
begin
Proc:=Declarations.Parent as TPasProcedure;
if not (pmAssembler in Proc.Modifiers) then
ParseExc(nParserExpectTokenError,SParserExpectTokenError,['begin']);
SetBlock(declNone);
ParseProcAsmBlock(TProcedureBody(Declarations));
break;
end
else
ParseExcSyntaxError;
end;
tklabel:
begin
SetBlock(declNone);
@ -3319,11 +3339,11 @@ begin
NextToken;
if CurToken in [tkString,tkIdentifier] then
begin
// extrenal libname
// external libname
// external libname name XYZ
// external name XYZ
Tok:=UpperCase(CurTokenString);
if Not ((curtoken=tkIdentifier) and (Tok='NAME')) then
if Not ((CurToken=tkIdentifier) and (Tok='NAME')) then
begin
E:=DoParseExpression(Parent);
if Assigned(P) then
@ -3334,7 +3354,7 @@ begin
else
begin
Tok:=UpperCase(CurTokenString);
if ((curtoken=tkIdentifier) and (Tok='NAME')) then
if ((CurToken=tkIdentifier) and (Tok='NAME')) then
begin
NextToken;
if not (CurToken in [tkString,tkIdentifier]) then
@ -3789,7 +3809,6 @@ var
BeginBlock: TPasImplBeginBlock;
SubBlock: TPasImplElement;
begin
BeginBlock := TPasImplBeginBlock(CreateElement(TPasImplBeginBlock, '', Parent));
Parent.Body := BeginBlock;
repeat
@ -3809,7 +3828,17 @@ begin
// writeln('TPasParser.ParseProcBeginBlock ended ',curtokenstring);
end;
procedure TPasParser.ParseAsmBlock(AsmBlock : TPasImplAsmStatement);
procedure TPasParser.ParseProcAsmBlock(Parent: TProcedureBody);
var
AsmBlock: TPasImplAsmStatement;
begin
AsmBlock:=TPasImplAsmStatement(CreateElement(TPasImplAsmStatement,'',Parent));
Parent.Body:=AsmBlock;
ParseAsmBlock(AsmBlock);
ExpectToken(tkSemicolon);
end;
procedure TPasParser.ParseAsmBlock(AsmBlock: TPasImplAsmStatement);
begin
if po_asmwhole in Options then
begin
@ -3917,9 +3946,9 @@ begin
while True do
begin
NextToken;
//WriteLn(i,'Token=',CurTokenText);
//WriteLn('Token=',CurTokenText);
case CurToken of
tkasm :
tkasm:
begin
El:=TPasImplElement(CreateElement(TPasImplAsmStatement,'',CurBlock));
ParseAsmBlock(TPasImplAsmStatement(El));
@ -3940,9 +3969,10 @@ begin
begin
NextToken;
Left:=DoParseExpression(CurBlock);
UNgettoken;
UngetToken;
El:=TPasImplIfElse(CreateElement(TPasImplIfElse,'',CurBlock));
TPasImplIfElse(El).ConditionExpr:=Left;
Left.Parent:=El;
//WriteLn(i,'IF Condition="',Condition,'" Token=',CurTokenText);
CreateBlock(TPasImplIfElse(El));
ExpectToken(tkthen);
@ -4003,8 +4033,8 @@ begin
begin
// while Condition do
NextToken;
left:=DoParseExpression(Parent);
ungettoken;
left:=DoParseExpression(CurBlock);
UngetToken;
//WriteLn(i,'WHILE Condition="',Condition,'" Token=',CurTokenText);
El:=TPasImplWhileDo(CreateElement(TPasImplWhileDo,'',CurBlock));
TPasImplWhileDo(El).ConditionExpr:=left;
@ -4013,7 +4043,7 @@ begin
end;
tkgoto:
begin
nexttoken;
NextToken;
curblock.AddCommand('goto '+curtokenstring);
expecttoken(tkSemiColon);
end;
@ -4080,17 +4110,18 @@ begin
// with Expr, Expr do
SrcPos:=Scanner.CurSourcePos;
NextToken;
Left:=DoParseExpression(Parent);
Left:=DoParseExpression(CurBlock);
//writeln(i,'WITH Expr="',Expr,'" Token=',CurTokenText);
El:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock,SrcPos));
TPasImplWithDo(El).AddExpression(Left);
Left.Parent:=El;
CreateBlock(TPasImplWithDo(El));
repeat
if CurToken=tkdo then break;
if CurToken<>tkComma then
ParseExcTokenError(TokenInfos[tkdo]);
NextToken;
Left:=DoParseExpression(Parent);
Left:=DoParseExpression(CurBlock);
//writeln(i,'WITH ...,Expr="',Expr,'" Token=',CurTokenText);
TPasImplWithDo(CurBlock).AddExpression(Left);
until false;
@ -4098,7 +4129,7 @@ begin
tkcase:
begin
NextToken;
Left:=DoParseExpression(Parent);
Left:=DoParseExpression(CurBlock);
UngetToken;
//writeln(i,'CASE OF Expr="',Expr,'" Token=',CurTokenText);
ExpectToken(tkof);
@ -4299,7 +4330,7 @@ begin
if CurBlock is TPasImplRepeatUntil then
begin
NextToken;
Left:=DoParseExpression(Parent);
Left:=DoParseExpression(CurBlock);
UngetToken;
TPasImplRepeatUntil(CurBlock).ConditionExpr:=Left;
//WriteLn(i,'UNTIL Condition="',Condition,'" Token=',CurTokenString);
@ -4308,7 +4339,7 @@ begin
ParseExcSyntaxError;
end;
else
left:=DoParseExpression(Parent);
left:=DoParseExpression(CurBlock);
case CurToken of
tkAssign,
tkAssignPlus,
@ -4319,7 +4350,7 @@ begin
// assign statement
Ak:=TokenToAssignKind(CurToken);
NextToken;
right:=DoParseExpression(Parent); // this may solve TPasImplWhileDo.AddElement BUG
right:=DoParseExpression(CurBlock); // this may solve TPasImplWhileDo.AddElement BUG
El:=TPasImplAssign(CreateElement(TPasImplAssign,'',CurBlock));
left.Parent:=El;
right.Parent:=El;

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

@ -153,6 +153,10 @@ type
// strings
Procedure TestString_SetLength;
Procedure TestString_Element;
Procedure TestStringElement_MissingArgFail;
Procedure TestStringElement_IndexNonIntFail;
Procedure TestStringElement_AsVarArgFail;
// enums
Procedure TestEnums;
@ -178,8 +182,6 @@ type
Procedure TestBooleanOperators;
Procedure TestStringOperators;
Procedure TestFloatOperators;
Procedure TestStringElementMissingArgFail;
Procedure TestStringElementIndexNonIntFail;
Procedure TestCAssignments;
Procedure TestTypeCastBaseTypes;
Procedure TestTypeCastStrToIntFail;
@ -240,6 +242,7 @@ type
Procedure TestExit;
Procedure TestBreak;
Procedure TestContinue;
Procedure TestProcedureExternal;
// record
Procedure TestRecord;
@ -299,6 +302,7 @@ type
Procedure TestClass_ConDestructor_CallInherited;
Procedure TestClass_Constructor_Inherited;
Procedure TestClass_SubObject;
Procedure TestClass_WithClassInstance;
// class of
Procedure TestClassOf;
@ -1585,6 +1589,55 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestString_Element;
begin
StartProgram(false);
Add('var');
Add(' s: string;');
Add(' c: char;');
Add('begin');
Add(' if s[1]=s then ;');
Add(' if s=s[2] then ;');
Add(' if s[3+4]=c then ;');
Add(' if c=s[5] then ;');
Add(' c:=s[6];');
Add(' s[7]:=c;');
Add(' s[8]:=''a'';');
ParseProgram;
end;
procedure TTestResolver.TestStringElement_MissingArgFail;
begin
StartProgram(false);
Add('var s: string;');
Add('begin');
Add(' if s[]=s then ;');
CheckResolverException('Missing parameter character index',PasResolver.nMissingParameterX);
end;
procedure TTestResolver.TestStringElement_IndexNonIntFail;
begin
StartProgram(false);
Add('var s: string;');
Add('begin');
Add(' if s[true]=s then ;');
CheckResolverException('Incompatible types: got "Boolean" expected "Char"',
PasResolver.nIncompatibleTypesGotExpected);
end;
procedure TTestResolver.TestStringElement_AsVarArgFail;
begin
StartProgram(false);
Add('procedure DoIt(var c: char);');
Add('begin');
Add('end;');
Add('var s: string;');
Add('begin');
Add(' DoIt(s[1]);');
CheckResolverException('Variable identifier expected',
PasResolver.nVariableIdentifierExpected);
end;
procedure TTestResolver.TestEnums;
begin
StartProgram(false);
@ -2121,25 +2174,6 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestStringElementMissingArgFail;
begin
StartProgram(false);
Add('var s: string;');
Add('begin');
Add(' if s[]=s then ;');
CheckResolverException('Missing parameter character index',PasResolver.nMissingParameterX);
end;
procedure TTestResolver.TestStringElementIndexNonIntFail;
begin
StartProgram(false);
Add('var s: string;');
Add('begin');
Add(' if s[true]=s then ;');
CheckResolverException('Incompatible types: got "Boolean" expected "Comp"',
PasResolver.nIncompatibleTypesGotExpected);
end;
procedure TTestResolver.TestCAssignments;
begin
StartProgram(false);
@ -3060,6 +3094,23 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestProcedureExternal;
begin
StartProgram(false);
Add('procedure {#ProcA}ProcA; external ''ExtProcA'';');
Add('function {#FuncB}FuncB: longint; external ''ExtFuncB'';');
Add('function {#FuncC}FuncC(d: double): string; external ''ExtFuncC'';');
Add('var');
Add(' i: longint;');
Add(' s: string;');
Add('begin');
Add(' {@ProcA}ProcA;');
Add(' i:={@FuncB}FuncB;');
Add(' i:={@FuncB}FuncB();');
Add(' s:={@FuncC}FuncC(1.2);');
ParseProgram;
end;
procedure TTestResolver.TestRecord;
begin
StartProgram(false);
@ -4371,6 +4422,78 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestClass_WithClassInstance;
var
aMarker: PSrcMarker;
Elements: TFPList;
ActualRefWith: Boolean;
i: Integer;
El: TPasElement;
Ref: TResolvedReference;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' FInt: longint;');
Add(' FObj: TObject;');
Add(' FArr: array of longint;');
Add(' constructor Create;');
Add(' function GetSize: longint;');
Add(' procedure SetSize(Value: longint);');
Add(' function GetItems(Index: longint): longint;');
Add(' procedure SetItems(Index, Value: longint);');
Add(' property Size: longint read GetSize write SetSize;');
Add(' property Items[Index: longint]: longint read GetItems write SetItems;');
Add(' end;');
Add('constructor TObject.Create; begin end;');
Add('function TObject.GetSize: longint; begin end;');
Add('procedure TObject.SetSize(Value: longint); begin end;');
Add('function TObject.GetItems(Index: longint): longint; begin end;');
Add('procedure TObject.SetItems(Index, Value: longint); begin end;');
Add('var');
Add(' Obj: TObject;');
Add(' i: longint;');
Add('begin');
Add(' with TObject.Create do begin');
Add(' {#A}FInt:=3;');
Add(' i:={#B}FInt;');
Add(' i:={#C}GetSize;');
Add(' i:={#D}GetSize();');
Add(' {#E}SetSize(i);');
Add(' i:={#F}Size;');
Add(' {#G}Size:=i;');
Add(' i:={#H}Items[i];');
Add(' {#I}Items[i]:=i;');
Add(' i:={#J}FArr[i];');
Add(' {#K}FArr[i]:=i;');
Add(' end;');
ParseProgram;
aMarker:=FirstSrcMarker;
while aMarker<>nil do
begin
writeln('TTestResolver.TestClass_WithClassInstance ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
Elements:=FindElementsAt(aMarker);
try
ActualRefWith:=false;
for i:=0 to Elements.Count-1 do
begin
El:=TPasElement(Elements[i]);
writeln('TTestResolver.TestClass_WithClassInstance ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
if not (El.CustomData is TResolvedReference) then continue;
Ref:=TResolvedReference(El.CustomData);
if Ref.WithExprScope=nil then continue;
ActualRefWith:=true;
break;
end;
if not ActualRefWith then
RaiseErrorAtSrcMarker('expected Ref.WithExprScope<>nil at "#'+aMarker^.Identifier+', but got nil"',aMarker);
finally
Elements.Free;
end;
aMarker:=aMarker^.Next;
end;
end;
procedure TTestResolver.TestClassOf;
begin
StartProgram(false);
@ -5142,6 +5265,8 @@ begin
Add('end;');
Add('procedure TObject.SetB(Index: longint; Value: longint);');
Add('begin');
Add(' if Value=Self[Index] then ;');
Add(' Self[Index]:=Value;');
Add('end;');
Add('var o: TObject;');
Add('begin');

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

File diff suppressed because it is too large Load Diff

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

@ -268,7 +268,6 @@ begin
E:=TJSExpressionStatement(Convert(R,TJSExpressionStatement));
AssertNotNull('Have call node',E.A);
AssertEquals('Have call expression',TJSCallExpression,E.A.ClassType);
AssertEquals('Have call expression',TJSCallExpression,E.A.ClassType);
C:=TJSCallExpression(E.A);
AssertIdentifier('Call expression',C.Expr,'a');
end;
@ -972,12 +971,15 @@ Procedure TTestExpressionConverter.TestBinaryDiv;
Var
B : TBinaryExpr;
E : TJSMultiplicativeExpressionDiv;
C: TJSCallExpression;
Args: TJSArguments;
begin
B:=TBinaryExpr.Create(Nil,pekBinary,eopDiv);
B.left:=CreateLiteral(1.23);
B.Right:=CreateLiteral(3.45);
E:=TJSMultiplicativeExpressionDiv(TestBinaryExpression(B,TJSMultiplicativeExpressionDiv));
C:=TJSCallExpression(Convert(B,TJSCallExpression));
Args:=TJSArguments(AssertElement('Math.floor param',TJSArguments,C.Args));
E:=TJSMultiplicativeExpressionDiv(AssertElement('param',TJSMultiplicativeExpressionDiv,Args.Elements.Elements[0].Expr));
AssertLiteral('Correct left literal for div',E.A,1.23);
AssertLiteral('Correct right literal for div',E.B,3.45);
end;
@ -1013,13 +1015,13 @@ end;
Procedure TTestExpressionConverter.TestBinarySHR;
Var
B : TBinaryExpr;
E : TJSRShiftExpression;
E : TJSURShiftExpression;
begin
B:=TBinaryExpr.Create(Nil,pekBinary,eopSHR);
B.left:=CreateLiteral(13);
B.Right:=CreateLiteral(3);
E:=TJSRShiftExpression(TestBinaryExpression(B,TJSRShiftExpression));
E:=TJSURShiftExpression(TestBinaryExpression(B,TJSURShiftExpression));
AssertLiteral('Correct left literal for shr',E.A,13);
AssertLiteral('Correct right literal for shr',E.B,3);
end;

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

@ -136,7 +136,9 @@ type
Published
// modules
Procedure TestEmptyProgram;
Procedure TestEmptyProgramUseStrict;
Procedure TestEmptyUnit;
Procedure TestEmptyUnitUseStrict;
// vars/const
Procedure TestVarInt;
@ -149,8 +151,11 @@ type
// strings
Procedure TestCharConst;
Procedure TestChar_Compare;
Procedure TestStringConst;
Procedure TestString_Compare;
Procedure TestString_SetLength;
Procedure TestString_CharAt;
// ToDo: TestString: read, write []
Procedure TestEmptyProc;
@ -174,6 +179,9 @@ type
Procedure TestExit;
Procedure TestBreak;
Procedure TestContinue;
Procedure TestProcedureExternal;
Procedure TestProcedureAsm;
Procedure TestProcedureAssembler;
// ToDo: pass by reference
@ -190,9 +198,6 @@ type
Procedure TestIncDec;
Procedure TestAssignments;
Procedure TestArithmeticOperators1;
// test integer := double
// test integer := integer + double
// test pass double to an integer parameter
Procedure TestLogicalOperators;
Procedure TestBitwiseOperators;
Procedure TestFunctionInt;
@ -211,11 +216,12 @@ type
Procedure TestCaseOfNoElse;
Procedure TestCaseOfNoElse_UseSwitch;
Procedure TestCaseOfRange;
Procedure TestWithRecordDo;
// arrays
Procedure TestArray_Dynamic;
Procedure TestArray_Dynamic_Nil;
// ToDo: TestArray_LowHigh
Procedure TestArray_DynMultiDimensional;
// classes
Procedure TestClass_TObjectDefaultConstructor;
@ -233,12 +239,15 @@ type
Procedure TestClass_Property_ClassMethod;
Procedure TestClass_Property_Index;
Procedure TestClass_PropertyOfTypeArray;
Procedure TestClass_PropertyDefault;
Procedure TestClass_Assigned;
Procedure TestClass_WithClassDoCreate;
Procedure TestClass_WithClassInstDoProperty;
Procedure TestClass_WithClassInstDoPropertyWithParams;
Procedure TestClass_WithClassInstDoFunc;
// ToDo: overload
// ToDo: second constructor
// ToDo: call another constructor within a constructor
// ToDo: call class.classmethod
// ToDo: call instance.classmethod
// ToDo: property
// ToDo: event
// ToDo: class of
@ -888,7 +897,16 @@ begin
StartProgram(false);
Add('begin');
ConvertProgram;
CheckSource('Empty program','','');
CheckSource('TestEmptyProgram','','');
end;
procedure TTestModule.TestEmptyProgramUseStrict;
begin
Converter.Options:=Converter.Options+[coUseStrict];
StartProgram(false);
Add('begin');
ConvertProgram;
CheckSource('TestEmptyProgramUseStrict','"use strict";','');
end;
procedure TTestModule.TestEmptyUnit;
@ -897,6 +915,30 @@ begin
Add('interface');
Add('implementation');
ConvertUnit;
CheckSource('TestEmptyUnit',
LinesToStr([
'var $impl = {',
'};',
'this.$impl = $impl;'
]),
'');
end;
procedure TTestModule.TestEmptyUnitUseStrict;
begin
Converter.Options:=Converter.Options+[coUseStrict];
StartUnit(false);
Add('interface');
Add('implementation');
ConvertUnit;
CheckSource('TestEmptyUnitUseStrict',
LinesToStr([
'"use strict";',
'var $impl = {',
'};',
'this.$impl = $impl;'
]),
'');
end;
procedure TTestModule.TestVarInt;
@ -1563,6 +1605,76 @@ begin
]));
end;
procedure TTestModule.TestProcedureExternal;
begin
StartProgram(false);
Add('procedure Foo; external name ''console.log'';');
Add('function Bar: longint; external name ''get.item'';');
Add('function Bla(s: string): longint; external name ''apply.something'';');
Add('var');
Add(' i: longint;');
Add('begin');
Add(' Foo;');
Add(' i:=Bar;');
Add(' i:=Bla(''abc'');');
ConvertProgram;
CheckSource('TestProcedureExternal',
LinesToStr([ // statements
'this.i = 0;'
]),
LinesToStr([
'console.log();',
'this.i = get.item();',
'this.i = apply.something("abc");'
]));
end;
procedure TTestModule.TestProcedureAsm;
begin
StartProgram(false);
Add('function DoIt: longint;');
Add('begin;');
Add(' asm');
Add(' { a:{ b:{}, c:[]}, d:''1'' };');
Add(' end;');
Add('end;');
Add('begin');
ConvertProgram;
CheckSource('TestProcedureAsm',
LinesToStr([ // statements
'this.DoIt = function () {',
' var Result = 0;',
' { a:{ b:{}, c:[]}, d:''1'' };',
';',
'return Result;',
'};'
]),
LinesToStr([
''
]));
end;
procedure TTestModule.TestProcedureAssembler;
begin
StartProgram(false);
Add('function DoIt: longint; assembler;');
Add('asm');
Add('{ a:{ b:{}, c:[]}, d:''1'' };');
Add('end;');
Add('begin');
ConvertProgram;
CheckSource('TestProcedureAssembler',
LinesToStr([ // statements
'this.DoIt = function () {',
' { a:{ b:{}, c:[]}, d:''1'' };',
';',
'};'
]),
LinesToStr([
''
]));
end;
procedure TTestModule.TestEnumName;
begin
StartProgram(false);
@ -1988,6 +2100,49 @@ begin
]));
end;
procedure TTestModule.TestChar_Compare;
begin
StartProgram(false);
Add('var');
Add(' c: char;');
Add(' b: boolean;');
Add('begin');
Add(' b:=c=''1'';');
Add(' b:=''2''=c;');
Add(' b:=''3''=''4'';');
Add(' b:=c<>''5'';');
Add(' b:=''6''<>c;');
Add(' b:=c>''7'';');
Add(' b:=''8''>c;');
Add(' b:=c>=''9'';');
Add(' b:=''A''>=c;');
Add(' b:=c<''B'';');
Add(' b:=''C''<c;');
Add(' b:=c<=''D'';');
Add(' b:=''E''<=c;');
ConvertProgram;
CheckSource('TestChar_Compare',
LinesToStr([
'this.c="";',
'this.b = false;'
]),
LinesToStr([
'this.b = this.c == "1";',
'this.b = "2" == this.c;',
'this.b = "3" == "4";',
'this.b = this.c != "5";',
'this.b = "6" != this.c;',
'this.b = this.c > "7";',
'this.b = "8" > this.c;',
'this.b = this.c >= "9";',
'this.b = "A" >= this.c;',
'this.b = this.c < "B";',
'this.b = "C" < this.c;',
'this.b = this.c <= "D";',
'this.b = "E" <= this.c;',
'']));
end;
procedure TTestModule.TestStringConst;
begin
StartProgram(false);
@ -2002,7 +2157,7 @@ begin
Add(' s:=''"'';');
Add(' s:=''"''''"'';');
ConvertProgram;
CheckSource('TestCharConst',
CheckSource('TestStringConst',
LinesToStr([
'this.s="abc";'
]),
@ -2017,6 +2172,36 @@ begin
]));
end;
procedure TTestModule.TestString_Compare;
begin
StartProgram(false);
Add('var');
Add(' s, t: string;');
Add(' b: boolean;');
Add('begin');
Add(' b:=s=t;');
Add(' b:=s<>t;');
Add(' b:=s>t;');
Add(' b:=s>=t;');
Add(' b:=s<t;');
Add(' b:=s<=t;');
ConvertProgram;
CheckSource('TestString_Compare',
LinesToStr([ // statements
'this.s = "";',
'this.t = "";',
'this.b =false;'
]),
LinesToStr([ // this.$main
'this.b = this.s == this.t;',
'this.b = this.s != this.t;',
'this.b = this.s > this.t;',
'this.b = this.s >= this.t;',
'this.b = this.s < this.t;',
'this.b = this.s <= this.t;',
'']));
end;
procedure TTestModule.TestString_SetLength;
begin
StartProgram(false);
@ -2033,6 +2218,41 @@ begin
]));
end;
procedure TTestModule.TestString_CharAt;
begin
StartProgram(false);
Add('var');
Add(' s: string;');
Add(' c: char;');
Add(' b: boolean;');
Add('begin');
Add(' b:= s[1] = c;');
Add(' b:= c = s[1];');
Add(' b:= c <> s[1];');
Add(' b:= c > s[1];');
Add(' b:= c >= s[1];');
Add(' b:= c < s[1];');
Add(' b:= c <= s[1];');
Add(' s[1] := c;');
ConvertProgram;
CheckSource('TestString_CharAt',
LinesToStr([ // statements
'this.s = "";',
'this.c = "";',
'this.b = false;'
]),
LinesToStr([ // this.$main
'this.b = this.s.charAt(1-1) == this.c;',
'this.b = this.c == this.s.charAt(1 - 1);',
'this.b = this.c != this.s.charAt(1 - 1);',
'this.b = this.c > this.s.charAt(1 - 1);',
'this.b = this.c >= this.s.charAt(1 - 1);',
'this.b = this.c < this.s.charAt(1 - 1);',
'this.b = this.c <= this.s.charAt(1 - 1);',
'this.s = rtl.setCharAt(this.s, 1, this.c);',
'']));
end;
procedure TTestModule.TestProcTwoArgs;
begin
StartProgram(false);
@ -2573,6 +2793,41 @@ begin
]));
end;
procedure TTestModule.TestWithRecordDo;
begin
StartProgram(false);
Add('type');
Add(' TRec = record');
Add(' vI: longint;');
Add(' end;');
Add('var');
Add(' Int: longint;');
Add(' r: TRec;');
Add('begin');
Add(' with r do');
Add(' int:=vi;');
Add(' with r do begin');
Add(' int:=vi;');
Add(' vi:=int;');
Add(' end;');
ConvertProgram;
CheckSource('TestWithRecordDo',
LinesToStr([ // statements
'this.TRec = function () {',
' this.vI = 0;',
'};',
'this.Int = 0;',
'this.r = new this.TRec();'
]),
LinesToStr([ // this.$main
'var $with1 = this.r;',
'this.Int = $with1.vI;',
'var $with2 = this.r;',
'this.Int = $with2.vI;',
'$with2.vI = this.Int;'
]));
end;
procedure TTestModule.TestClass_TObjectDefaultConstructor;
begin
StartProgram(false);
@ -2605,8 +2860,8 @@ begin
]),
LinesToStr([ // this.$main
'this.Obj = this.TObject.$create("Create");',
'this.Obj.$destroy("Destroy");'
]));
'this.Obj.$destroy("Destroy");',
'']));
end;
procedure TTestModule.TestClass_TObjectConstructorWithParams;
@ -3477,6 +3732,321 @@ begin
]));
end;
procedure TTestModule.TestClass_PropertyDefault;
begin
StartProgram(false);
Add('type');
Add(' TArray = array of longint;');
Add(' TObject = class');
Add(' FItems: TArray;');
Add(' function GetItems(Index: longint): longint;');
Add(' procedure SetItems(Index, Value: longint);');
Add(' property Items[Index: longint]: longint read getitems write setitems; default;');
Add(' end;');
Add('function tobject.getitems(index: longint): longint;');
Add('begin');
Add('end;');
Add('procedure tobject.setitems(index, value: longint);');
Add('begin');
Add(' Self[1]:=2;');
Add(' Self[3]:=Self[index];');
Add(' Self[index]:=Self[Self[value]];');
Add(' Self[Self[4]]:=value;');
Add('end;');
Add('var Obj: tobject;');
Add('begin');
Add(' obj[11]:=12;');
Add(' obj[13]:=obj[14];');
Add(' obj[obj[15]]:=obj[obj[15]];');
ConvertProgram;
CheckSource('TestClass_PropertyDefault',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' this.FItems = [];',
' };',
' this.GetItems = function (Index) {',
' var Result = 0;',
' return Result;',
' };',
' this.SetItems = function (Index, Value) {',
' this.SetItems(1, 2);',
' this.SetItems(3, this.GetItems(Index));',
' this.SetItems(Index, this.GetItems(this.GetItems(Value)));',
' this.SetItems(this.GetItems(4), Value);',
' };',
'});',
'this.Obj = null;'
]),
LinesToStr([ // this.$main
'this.Obj.SetItems(11, 12);',
'this.Obj.SetItems(13, this.Obj.GetItems(14));',
'this.Obj.SetItems(this.Obj.GetItems(15), this.Obj.GetItems(this.Obj.GetItems(15)));'
]));
end;
procedure TTestModule.TestClass_Assigned;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' end;');
Add('var');
Add(' Obj: tobject;');
Add(' b: boolean;');
Add('begin');
Add(' if Assigned(obj) then ;');
Add(' b:=Assigned(obj) or false;');
ConvertProgram;
CheckSource('TestClass_Assigned',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
'});',
'this.Obj = null;',
'this.b = false;'
]),
LinesToStr([ // this.$main
'if (this.Obj != null) {',
'};',
'this.b = (this.Obj != null) || false;'
]));
end;
procedure TTestModule.TestClass_WithClassDoCreate;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' aBool: boolean;');
Add(' Arr: array of boolean;');
Add(' constructor Create;');
Add(' end;');
Add('constructor TObject.Create; begin end;');
Add('var');
Add(' Obj: tobject;');
Add(' b: boolean;');
Add('begin');
Add(' with tobject.create do begin');
Add(' b:=abool;');
Add(' abool:=b;');
Add(' b:=arr[1];');
Add(' arr[2]:=b;');
Add(' end;');
Add(' with tobject do');
Add(' obj:=create;');
Add(' with obj do begin');
Add(' create;');
Add(' b:=abool;');
Add(' abool:=b;');
Add(' b:=arr[3];');
Add(' arr[4]:=b;');
Add(' end;');
ConvertProgram;
CheckSource('TestClass_WithClassDoCreate',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' this.aBool = false;',
' this.Arr = [];',
' };',
' this.Create = function () {',
' };',
'});',
'this.Obj = null;',
'this.b = false;'
]),
LinesToStr([ // this.$main
'var $with1 = this.TObject.$create("Create");',
'this.b = $with1.aBool;',
'$with1.aBool = this.b;',
'this.b = $with1.Arr[1];',
'$with1.Arr[2] = this.b;',
'var $with2 = this.TObject;',
'this.Obj = $with2.$create("Create");',
'var $with3 = this.Obj;',
'$with3.Create();',
'this.b = $with3.aBool;',
'$with3.aBool = this.b;',
'this.b = $with3.Arr[3];',
'$with3.Arr[4] = this.b;',
'']));
end;
procedure TTestModule.TestClass_WithClassInstDoProperty;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' FInt: longint;');
Add(' constructor Create;');
Add(' function GetSize: longint;');
Add(' procedure SetSize(Value: longint);');
Add(' property Int: longint read FInt write FInt;');
Add(' property Size: longint read GetSize write SetSize;');
Add(' end;');
Add('constructor TObject.Create; begin end;');
Add('function TObject.GetSize: longint; begin; end;');
Add('procedure TObject.SetSize(Value: longint); begin; end;');
Add('var');
Add(' Obj: tobject;');
Add(' i: longint;');
Add('begin');
Add(' with TObject.Create do begin');
Add(' i:=int;');
Add(' int:=i;');
Add(' i:=size;');
Add(' size:=i;');
Add(' end;');
Add(' with obj do begin');
Add(' i:=int;');
Add(' int:=i;');
Add(' i:=size;');
Add(' size:=i;');
Add(' end;');
ConvertProgram;
CheckSource('TestClass_WithClassInstDoProperty',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' this.FInt = 0;',
' };',
' this.Create = function () {',
' };',
' this.GetSize = function () {',
' var Result = 0;',
' return Result;',
' };',
' this.SetSize = function (Value) {',
' };',
'});',
'this.Obj = null;',
'this.i = 0;'
]),
LinesToStr([ // this.$main
'var $with1 = this.TObject.$create("Create");',
'this.i = $with1.FInt;',
'$with1.FInt = this.i;',
'this.i = $with1.GetSize();',
'$with1.SetSize(this.i);',
'var $with2 = this.Obj;',
'this.i = $with2.FInt;',
'$with2.FInt = this.i;',
'this.i = $with2.GetSize();',
'$with2.SetSize(this.i);',
'']));
end;
procedure TTestModule.TestClass_WithClassInstDoPropertyWithParams;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' constructor Create;');
Add(' function GetItems(Index: longint): longint;');
Add(' procedure SetItems(Index, Value: longint);');
Add(' property Items[Index: longint]: longint read GetItems write SetItems;');
Add(' end;');
Add('constructor TObject.Create; begin end;');
Add('function tobject.getitems(index: longint): longint; begin; end;');
Add('procedure tobject.setitems(index, value: longint); begin; end;');
Add('var');
Add(' Obj: tobject;');
Add(' i: longint;');
Add('begin');
Add(' with TObject.Create do begin');
Add(' i:=Items[1];');
Add(' Items[2]:=i;');
Add(' end;');
Add(' with obj do begin');
Add(' i:=Items[3];');
Add(' Items[4]:=i;');
Add(' end;');
ConvertProgram;
CheckSource('TestClass_WithClassInstDoPropertyWithParams',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.Create = function () {',
' };',
' this.GetItems = function (Index) {',
' var Result = 0;',
' return Result;',
' };',
' this.SetItems = function (Index, Value) {',
' };',
'});',
'this.Obj = null;',
'this.i = 0;'
]),
LinesToStr([ // this.$main
'var $with1 = this.TObject.$create("Create");',
'this.i = $with1.GetItems(1);',
'$with1.SetItems(2, this.i);',
'var $with2 = this.Obj;',
'this.i = $with2.GetItems(3);',
'$with2.SetItems(4, this.i);',
'']));
end;
procedure TTestModule.TestClass_WithClassInstDoFunc;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' constructor Create;');
Add(' function GetSize: longint;');
Add(' procedure SetSize(Value: longint);');
Add(' end;');
Add('constructor TObject.Create; begin end;');
Add('function TObject.GetSize: longint; begin; end;');
Add('procedure TObject.SetSize(Value: longint); begin; end;');
Add('var');
Add(' Obj: tobject;');
Add(' i: longint;');
Add('begin');
Add(' with TObject.Create do begin');
Add(' i:=GetSize;');
Add(' i:=GetSize();');
Add(' SetSize(i);');
Add(' end;');
Add(' with obj do begin');
Add(' i:=GetSize;');
Add(' i:=GetSize();');
Add(' SetSize(i);');
Add(' end;');
ConvertProgram;
CheckSource('TestClass_WithClassInstDoFunc',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.Create = function () {',
' };',
' this.GetSize = function () {',
' var Result = 0;',
' return Result;',
' };',
' this.SetSize = function (Value) {',
' };',
'});',
'this.Obj = null;',
'this.i = 0;'
]),
LinesToStr([ // this.$main
'var $with1 = this.TObject.$create("Create");',
'this.i = $with1.GetSize();',
'this.i = $with1.GetSize();',
'$with1.SetSize(this.i);',
'var $with2 = this.Obj;',
'this.i = $with2.GetSize();',
'this.i = $with2.GetSize();',
'$with2.SetSize(this.i);',
'']));
end;
procedure TTestModule.TestArray_Dynamic;
begin
StartProgram(false);
@ -3484,20 +4054,30 @@ begin
Add(' TArrayInt = array of longint;');
Add('var');
Add(' Arr: TArrayInt;');
Add(' i: longint;');
Add('begin');
Add(' SetLength(arr,3);');
Add(' arr[0]:=4;');
Add(' arr[1]:=length(arr)+arr[0];');
Add(' arr[i]:=5;');
Add(' arr[arr[i]]:=arr[6];');
Add(' i:=low(arr);');
Add(' i:=high(arr);');
ConvertProgram;
CheckSource('TestArray_Dynamic',
LinesToStr([ // statements
'this.Arr = [];'
'this.Arr = [];',
'this.i = 0;'
]),
LinesToStr([ // this.$main
'this.Arr = rtl.setArrayLength(this.Arr,3,0);',
'this.Arr[0] = 4;',
'this.Arr[1] = rtl.length(this.Arr)+this.Arr[0];'
]));
'this.Arr[1] = rtl.length(this.Arr)+this.Arr[0];',
'this.Arr[this.i] = 5;',
'this.Arr[this.Arr[this.i]] = this.Arr[6];',
'this.i = 0;',
'this.i = rtl.length(this.Arr);',
'']));
end;
procedure TTestModule.TestArray_Dynamic_Nil;
@ -3523,6 +4103,56 @@ begin
]));
end;
procedure TTestModule.TestArray_DynMultiDimensional;
begin
StartProgram(false);
Add('type');
Add(' TArrayInt = array of longint;');
Add(' TArrayArrayInt = array of TArrayInt;');
Add('var');
Add(' Arr: TArrayInt;');
Add(' Arr2: TArrayArrayInt;');
Add(' i: longint;');
Add('begin');
Add(' arr2:=nil;');
Add(' if arr2=nil then;');
Add(' if nil=arr2 then;');
Add(' i:=low(arr2);');
Add(' i:=low(arr2[1]);');
Add(' i:=high(arr2);');
Add(' i:=high(arr2[2]);');
Add(' arr2[3]:=arr;');
Add(' arr2[4][5]:=i;');
Add(' i:=arr2[6][7];');
Add(' arr2[8,9]:=i;');
Add(' i:=arr2[10,11];');
Add(' SetLength(arr2,14);');
Add(' SetLength(arr2[15],16);');
ConvertProgram;
CheckSource('TestArray_Dynamic',
LinesToStr([ // statements
'this.Arr = [];',
'this.Arr2 = [];',
'this.i = 0;'
]),
LinesToStr([ // this.$main
'this.Arr2 = null;',
'if (this.Arr2 == null) {};',
'if (null == this.Arr2) {};',
'this.i = 0;',
'this.i = 0;',
'this.i = rtl.length(this.Arr2);',
'this.i = rtl.length(this.Arr2[2]);',
'this.Arr2[3] = this.Arr;',
'this.Arr2[4][5] = this.i;',
'this.i = this.Arr2[6][7];',
'this.Arr2[8][9] = this.i;',
'this.i = this.Arr2[10][11];',
'this.Arr2 = rtl.setArrayLength(this.Arr2, 14, []);',
'this.Arr2[15] = rtl.setArrayLength(this.Arr2[15], 16, 0);',
'']));
end;
Initialization
RegisterTests([TTestModule]);
end.