From bc2280500009075994eb2bb028316dd60655c161 Mon Sep 17 00:00:00 2001 From: michael <michael@freepascal.org> Date: Sun, 12 Feb 2017 15:16:00 +0000 Subject: [PATCH] * Patch from Mattias Gaertner: 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 - --- packages/fcl-js/src/jstree.pp | 2 +- packages/fcl-passrc/src/pasresolver.pp | 55 +- packages/fcl-passrc/src/pastree.pp | 32 +- packages/fcl-passrc/src/pparser.pp | 107 ++-- packages/fcl-passrc/tests/tcresolver.pas | 167 +++++- packages/pastojs/src/fppas2js.pp | 694 ++++++++++++++++++----- packages/pastojs/tests/tcconverter.pp | 12 +- packages/pastojs/tests/tcmodules.pas | 658 ++++++++++++++++++++- 8 files changed, 1477 insertions(+), 250 deletions(-) diff --git a/packages/fcl-js/src/jstree.pp b/packages/fcl-js/src/jstree.pp index 5c6b95e613..c50044ee4c 100644 --- a/packages/fcl-js/src/jstree.pp +++ b/packages/fcl-js/src/jstree.pp @@ -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) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 3fd0e483c5..bcd8d6007f 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -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; diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index ace1e02ea2..c32b2d6251 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -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; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index b6c7659205..6f6dffb063 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -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; diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 26005ee7a8..b642db324b 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -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'); diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 578e911ef2..220419a982 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -38,6 +38,7 @@ - try..except, try..except on else - raise, raise E - asm..end + - assembler; asm..end; - type alias - inc/dec to += -= - case-of @@ -60,11 +61,15 @@ - property of type array - class property - accessors non static + - Assigned() + - default property - arrays - init as "arr = []" - SetLength(arr,len) becomes arr = SetLength(arr,len,defaultvalue) - length(arr) - read, write element arr[index] + - low(), high() + - multi dimensional [index1,index2] -> [index1][index2] - rename name conflicts with js identifiers: apply, bind, call, prototype, ... - break - continue @@ -83,26 +88,26 @@ - set operators +, -, *, ><, =, <>, >=, <= - in-operator - low(), high() + - string: read and write char aString[] + - procedure modifier external 'name' + - option to add "use strict"; + - with-do + - with record do i:=v; + - with classinstance do begin create; i:=v; f(); i:=a[]; end; ToDos: + - use CreateTypeRef - use UTF8 string literals - - string: [] + - proc types - classes - - Assigned() - overloads, reintroduce - reintroduced variables - - default property - class of - type casts - events - pass by reference - create unique id for local const - rename overloaded procs, append $0, $1, ... - - assembler proc modifier: asm..end as whole body - - with-do - - 'use strict' to allow javascript compilers optimize better - - procedure modifier external - - integer := double -> integer = Math.floor(double) - sets - pass set as non const parameter -> cloneSet - set of char @@ -111,28 +116,32 @@ - set of char range - arrays - array of record: setlength - - multi dimensional [index1,index2] -> [index1][index2] - static array: non 0 start index - static array: length - array of static array: setlength - array[char] - - low(), high() - constant - open arrays - - enums custom values - record const - copy record + - enums custom values - library - Fix file names on converter errors (relative instead of full) - - dotted unit names - option range checking + - pred(), succ(), aChar:=, aInteger:= - option typecast checking - optimizations: - -O1 insert local vars for global type references: + function for in-operator on set literal + -O1 insert local/unit vars for global type references: at start of intf var $r1; at end of impl: $r1=path; - -O1 enums: use values directly + -O1 insert unit vars for complex literals -O1 no function Result var when only assigned once + - dotted unit names + - objects, interfaces, + - class helpers, type helpers, record helpers, + - generics + - operator overloading Debug flags: -d<x> VerbosePas2JS @@ -178,6 +187,7 @@ const DefaultFuncNameLength = 'length'; // rtl.length DefaultFuncNameNewClassInstance = '$create'; DefaultFuncNameSetArrayLength = 'setArrayLength'; // rtl.setArrayLength + DefaultFuncNameSetCharAt = 'setCharAt'; // rtl.setCharAt DefaultFuncNameSetStringLength = 'setStringLength'; // rtl.setStringLength DefaultFuncNameSet_Clone = 'cloneSet'; // rtl.cloneSet := DefaultFuncNameSet_Create = 'createSet'; // rtl.createSet [...] @@ -193,6 +203,7 @@ const DefaultVarNameLoopEnd = '$loopend'; DefaultVarNameModules = 'pas'; DefaultVarNameRTL = 'rtl'; + DefaultVarNameWith = '$with'; DefaultPasResolverOptions = [proFixCaseOfOverrides,proClassPropertyNonStatic]; @@ -264,6 +275,8 @@ const const VarModifiersType = [vmClass,vmStatic]; + HighJSInteger = $fffffffffffff; + LowJSInteger = -$10000000000000; Type @@ -356,6 +369,29 @@ Type constructor Create(PasEl: TPasElement; JSEl: TJSElement; aParent: TConvertContext); override; end; + { TPas2JsElementData } + + TPas2JsElementData = Class(TPasElementBase) + private + FElement: TPasElementBase; + procedure SetElement(const AValue: TPasElementBase); + public + Owner: TObject; // e.g. a TPasToJSConverter + Next: TPas2JsElementData; // TPasToJSConverter uses this for its memory chain + constructor Create; virtual; + destructor Destroy; override; + property Element: TPasElementBase read FElement write SetElement; // can be TPasElement or TResolveData + end; + TPas2JsElementDataClass = class of TPas2JsElementData; + + { TP2JWithData } + + TP2JWithData = Class(TPas2JsElementData) + public + // Element is TPasWithExprScope + WithVarName: string; + end; + TRefPathKind = ( rpkPath, // e.g. "TObject" rpkPathWithDot, // e.g. "TObject." @@ -365,7 +401,8 @@ Type TPasToJsConverterOption = ( coLowerCase, // lowercase all identifiers, except conflicts with JS reserved words coSwitchStatement, // convert case-of into switch instead of if-then-else - coEnumNumbers // use enum numbers instead of names + coEnumNumbers, // use enum numbers instead of names + coUseStrict // insert 'use strict' ); TPasToJsConverterOptions = set of TPasToJsConverterOption; @@ -377,21 +414,22 @@ Type function GetUseLowerCase: boolean; inline; function GetUseSwitchStatement: boolean; inline; private + FFirstElementData, FLastElementData: TPas2JsElementData; FFuncNameAs: TJSString; FFuncNameCreateClass: TJSString; FFuncNameFreeClassInstance: TJSString; - FVarNameImplementation: TJSString; FFuncNameLength: TJSString; - FVarNameLoopEnd: TJSString; FFuncNameMain: TJSString; FFuncNameNewClassInstance: TJSString; - FOptions: TPasToJsConverterOptions; - FVarNameRTL: TJSString; FFuncNameSetArrayLength: TJSString; + FOptions: TPasToJsConverterOptions; + FVarNameImplementation: TJSString; + FVarNameLoopEnd: TJSString; + FVarNameRTL: TJSString; Function CreateBuiltInIdentifierExpr(AName: string): TJSPrimaryExpressionIdent; Function CreateConstDecl(El: TPasConst; AContext: TConvertContext): TJSElement; Function CreateIdentifierExpr(AName: string; El: TPasElement; AContext: TConvertContext): TJSPrimaryExpressionIdent; - Function CreateSubNameExpression(El: TPasElement; const Name: string; + Function CreateDeclNameExpression(El: TPasElement; const Name: string; AContext: TConvertContext): TJSPrimaryExpressionIdent; Function CreateSwitchStatement(El: TPasImplCaseOf; AContext: TConvertContext): TJSElement; Function CreateTypeDecl(El: TPasType; AContext: TConvertContext): TJSElement; @@ -403,6 +441,9 @@ Type procedure SetUseEnumNumbers(const AValue: boolean); procedure SetUseLowerCase(const AValue: boolean); procedure SetUseSwitchStatement(const AValue: boolean); + procedure AddElementData(Data: TPas2JsElementData); + function CreateElementData(DataClass: TPas2JsElementDataClass; + El: TPasElementBase): TPas2JsElementData; {$IFDEF EnableOldClass} Function ConvertClassConstructor(El: TPasConstructor; AContext: TConvertContext): TJSElement; virtual; {$ENDIF} @@ -430,6 +471,8 @@ Type FFuncNameSet_NotEqual: TJSString; FFuncNameSet_SymDiffSet: TJSString; FFuncNameSet_Union: TJSString; + FFuncNameSetCharAt: TJSString; + FVarNameWith: TJSString; type TTryExceptFindData = record HasRaiseWithoutObject: boolean; @@ -477,9 +520,10 @@ Type Function CreateRecordInit(aRecord: TPasRecordType; Expr: TPasElement; El: TPasElement; AContext: TConvertContext): TJSElement;virtual; Function CreateTypeRef(El: TPasType; AContext : TConvertContext): TJSElement;virtual; Function CreateReferencePath(El: TPasElement; AContext : TConvertContext; - Kind: TRefPathKind; Full: boolean = false): string; virtual; + Kind: TRefPathKind; Full: boolean = false; Ref: TResolvedReference = nil): string; virtual; Procedure CreateImplementationSection(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); Procedure CreateInitSection(El: TPasModule; Src: TJSSourceElements; AContext: TConvertContext); + Function CreateDotExpression(aParent: TPasElement; Left, Right: TJSElement): TJSElement;virtual; // Statements Function ConvertImplBlockElements(El: TPasImplBlock; AContext: TConvertContext): TJSElement; virtual; Function ConvertBeginEndStatement(El: TPasImplBeginBlock; AContext: TConvertContext): TJSElement; virtual; @@ -514,6 +558,7 @@ Type Function ConvertBuiltInBreak(El: TPasExpr; AContext: TConvertContext): TJSElement;virtual; Function ConvertBuiltInExit(El: TPasExpr; AContext: TConvertContext): TJSElement;virtual; Function ConvertBuiltInIncDec(El: TParamsExpr; AContext: TConvertContext): TJSElement;virtual; + Function ConvertBuiltInAssigned(El: TParamsExpr; AContext: TConvertContext): TJSElement;virtual; Function ConvertBuiltInOrd(El: TParamsExpr; AContext: TConvertContext): TJSElement;virtual; Function ConvertBuiltInLow(El: TParamsExpr; AContext: TConvertContext): TJSElement;virtual; Function ConvertBuiltInHigh(El: TParamsExpr; AContext: TConvertContext): TJSElement;virtual; @@ -552,6 +597,8 @@ Type Function ConvertEnumType(El: TPasEnumType; AContext: TConvertContext): TJSElement; virtual; Public Constructor Create; + destructor Destroy; override; + procedure ClearElementData; Function ConvertPasElement(El : TPasElement; Resolver: TPasResolver) : TJSElement; // options Property Options: TPasToJsConverterOptions read FOptions write FOptions; @@ -566,6 +613,7 @@ Type Property FuncNameMain: TJSString Read FFuncNameMain Write FFuncNameMain; Property FuncNameNewClassInstance: TJSString read FFuncNameNewClassInstance write FFuncNameNewClassInstance; Property FuncNameSetArrayLength: TJSString read FFuncNameSetArrayLength write FFuncNameSetArrayLength; + Property FuncNameSetCharAt: TJSString read FFuncNameSetCharAt write FFuncNameSetCharAt; Property FuncNameSetStringLength: TJSString read FFuncNameSetStringLength write FFuncNameSetStringLength; Property FuncNameSet_Clone: TJSString read FFuncNameSet_Clone write FFuncNameSet_Clone; // rtl.cloneSet := Property FuncNameSet_Create: TJSString read FFuncNameSet_Create write FFuncNameSet_Create; // rtl.createSet [...] @@ -581,6 +629,7 @@ Type Property VarNameLoopEnd: TJSString read FVarNameLoopEnd write FVarNameLoopEnd; Property VarNameModules: TJSString read FVarNameModules write FVarNameModules; Property VarNameRTL: TJSString read FVarNameRTL write FVarNameRTL; + Property VarNameWith: TJSString read FVarNameWith write FVarNameWith; end; var @@ -599,6 +648,37 @@ begin Result:=WideChar($D800+((u - $10000) shr 10))+WideChar($DC00+((u - $10000) and $3ff)); end; +{ TPas2JsElementData } + +procedure TPas2JsElementData.SetElement(const AValue: TPasElementBase); +begin + if FElement=AValue then Exit; + if FElement<>nil then + if FElement.CustomData<>Self then + raise EPas2JS.Create('') + else + FElement.CustomData:=nil; + FElement:=AValue; + if FElement<>nil then + if FElement.CustomData<>nil then + raise EPas2JS.Create('') + else + FElement.CustomData:=Self; +end; + +constructor TPas2JsElementData.Create; +begin + +end; + +destructor TPas2JsElementData.Destroy; +begin + Element:=nil; + Next:=nil; + Owner:=nil; + inherited Destroy; +end; + { TAssignContext } constructor TAssignContext.Create(PasEl: TPasElement; JSEl: TJSElement; @@ -789,7 +869,7 @@ Var FunDef: TJSFuncDef; FunBody: TJSFunctionBody; FunDecl: TJSFunctionDeclarationStatement; - ArgEx: TJSLiteral; + ArgEx, StrictExp: TJSLiteral; UsesSection: TPasSection; ModuleName: String; IntfContext: TInterfaceContext; @@ -836,6 +916,13 @@ begin Src:=TJSSourceElements(CreateElement(TJSSourceElements, El)); FunBody.A:=Src; + if coUseStrict in Options then + begin + StrictExp:=TJSLiteral(CreateElement(TJSLiteral,El)); + StrictExp.Value.AsString:='use strict'; + AddToSourceElements(Src,StrictExp); + end; + IntfContext:=TInterfaceContext.Create(El,Src,AContext); try IntfContext.This:=El; @@ -937,8 +1024,7 @@ begin FunName:=String(FuncNameNewClassInstance) else FunName:=String(FuncNameFreeClassInstance); - if AContext is TFunctionContext then - FunName:='this.'+FunName; + FunName:=CreateReferencePath(Proc,AContext,rpkPathWithDot,false,Ref)+FunName; C.Expr:=CreateBuiltInIdentifierExpr(FunName); ArgElems:=C.Args.Elements; // parameter: "funcname" @@ -1400,84 +1486,32 @@ function TPasToJSConverter.ConvertSubIdentExpression(El: TBinaryExpr; AContext: TConvertContext): TJSElement; // connect El.left and El.right with a dot. var - Dot: TJSDotMemberExpression; + Left, Right: TJSElement; + OldIsWrite: Boolean; DotContext: TDotContext; - BParent, A, B: TJSElement; - ok, OldIsWrite: Boolean; begin Result:=nil; // convert left side OldIsWrite:=AContext.IsWrite; AContext.IsWrite:=false; - A:=ConvertElement(El.left,AContext); - if A=nil then + Left:=ConvertElement(El.left,AContext); + if Left=nil then RaiseInconsistency(20170201140821); AContext.IsWrite:=OldIsWrite; - - // create a dot-context for the right side - DotContext:=TDotContext.Create(El,A,AContext); - ok:=false; + // convert right side + DotContext:=TDotContext.Create(El,Left,AContext); + Right:=nil; try if AContext.Resolver<>nil then AContext.Resolver.ComputeElement(El.left,DotContext.LeftResolved,[rcReturnFuncResult]); - B:=ConvertElement(El.right,DotContext); - if A=nil then - RaiseInconsistency(20170201140827); - // create a TJSDotMemberExpression of A and the left-most identifier of B - // A becomes the new left-most element of B. - Result:=B; - BParent:=nil; - repeat - if (B.ClassType=TJSCallExpression) then - begin - BParent:=B; - B:=TJSCallExpression(B).Expr; - end - else if (B.ClassType=TJSBracketMemberExpression) then - begin - BParent:=B; - B:=TJSBracketMemberExpression(B).MExpr; - end - else if (B.ClassType=TJSDotMemberExpression) then - begin - BParent:=B; - B:=TJSDotMemberExpression(B).MExpr; - end - else if (B.ClassType=TJSPrimaryExpressionIdent) then - begin - // left-most identifier found - // -> replace it - Dot := TJSDotMemberExpression(CreateElement(TJSDotMemberExpression, El)); - Dot.MExpr := A; - Dot.Name := TJSPrimaryExpressionIdent(B).Name; - if Result=B then - Result:=Dot - else if BParent is TJSDotMemberExpression then - TJSDotMemberExpression(BParent).MExpr:=Dot - else if BParent is TJSCallExpression then - TJSCallExpression(BParent).Expr:=Dot - else - DoError(20170129141307,''); - FreeAndNil(B); - break; - end - else - begin - {$IFDEF VerbosePas2JS} - writeln('CreateDotExpression B=',B.ClassName); - {$ENDIF} - DoError(20161024191240,nMemberExprMustBeIdentifier,sMemberExprMustBeIdentifier,[],El); - end; - until false; - ok:=true; + Right:=ConvertElement(El.right,DotContext); finally DotContext.Free; - if not ok then - begin - FreeAndNil(A); - FreeAndNil(Result); - end; + if Right=nil then + Left.Free; end; + // connect via dot + Result:=CreateDotExpression(El,Left,Right); end; {$IFDEF EnableOldClass} @@ -1504,7 +1538,7 @@ begin Result:=I; end; -function TPasToJSConverter.CreateSubNameExpression(El: TPasElement; +function TPasToJSConverter.CreateDeclNameExpression(El: TPasElement; const Name: string; AContext: TConvertContext): TJSPrimaryExpressionIdent; var CurName: String; @@ -1596,7 +1630,9 @@ var Prop: TPasProperty; ImplicitCall: Boolean; AssignContext: TAssignContext; + PrimExpr: TPrimitiveExpr; begin + Result:=nil; if AContext=nil then ; if El.Kind<>pekIdent then RaiseInconsistency(20161024191255); @@ -1633,7 +1669,7 @@ begin AssignContext.Setter:=Decl; Call:=CreateCallExpression(El); AssignContext.Call:=Call; - Name:=CreateReferencePath(Decl,AContext,rpkPathAndName); + Name:=CreateReferencePath(Decl,AContext,rpkPathAndName,false,Ref); Call.Expr:=CreateBuiltInIdentifierExpr(Name); Call.Args.Elements.AddElement.Expr:=AssignContext.RightSide; AssignContext.RightSide:=nil; @@ -1690,9 +1726,19 @@ begin Name:=CreateReferencePath(Decl,AContext,rpkPathAndName,true); end; end + else if (Decl is TPasProcedure) and (TPasProcedure(Decl).LibrarySymbolName<>nil) then + begin + // an external function -> use the literal + Proc:=TPasProcedure(Decl); + PrimExpr:=Proc.LibrarySymbolName as TPrimitiveExpr; + Result:=TJSPrimaryExpressionIdent.Create(0,0); + TJSPrimaryExpressionIdent(Result).Name:= + TransFormStringLiteral(PrimExpr,AContext,PrimExpr.Value); + end else - Name:=CreateReferencePath(Decl,AContext,rpkPathAndName); - Result:=CreateBuiltInIdentifierExpr(Name); + Name:=CreateReferencePath(Decl,AContext,rpkPathAndName,false,Ref); + if Result=nil then + Result:=CreateBuiltInIdentifierExpr(Name); if ImplicitCall then begin @@ -1890,9 +1936,84 @@ function TPasToJSConverter.ConvertArrayParams(El: TParamsExpr; var ArgContext: TConvertContext; - procedure ConvertStringBracket; + function GetValueReference: TResolvedReference; + var + Value: TPasExpr; begin - RaiseNotSupported(El,AContext,20170206181006); + Result:=nil; + Value:=El.Value; + if (Value.ClassType=TPrimitiveExpr) + and (Value.CustomData is TResolvedReference) then + exit(TResolvedReference(Value.CustomData)); + end; + + procedure ConvertStringBracket; + var + Call: TJSCallExpression; + Param: TPasExpr; + Expr: TJSAdditiveExpressionMinus; + DotExpr: TJSDotMemberExpression; + AssignContext: TAssignContext; + Elements: TJSArrayLiteralElements; + AssignSt: TJSSimpleAssignStatement; + OldIsWrite: Boolean; + begin + Param:=El.Params[0]; + if AContext.IsWrite then + begin + // s[index] := value -> s = rtl.setCharAt(s,index,value) + AssignContext:=TAssignContext(AContext.GetContextOfType(TAssignContext)); + if AssignContext=nil then + RaiseNotSupported(El,AContext,20170211133909); + AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); + try + OldIsWrite:=AContext.IsWrite; + AContext.IsWrite:=false; + AssignSt.LHS:=ConvertElement(El.Value,AContext); + // rtl.setCharAt + Call:=CreateCallExpression(El); + AssignContext.Call:=Call; + AssignSt.Expr:=Call; + Elements:=Call.Args.Elements; + Call.Expr:=CreateMemberExpression([String(VarNameRTL),String(FuncNameSetCharAt)]); + // first param s + Elements.AddElement.Expr:=ConvertElement(El.Value,AContext); + AContext.IsWrite:=OldIsWrite; + // second param index + Elements.AddElement.Expr:=ConvertElement(Param,ArgContext); + // third param value + Elements.AddElement.Expr:=AssignContext.RightSide; + AssignContext.RightSide:=nil; + Result:=AssignSt + finally + if Result=nil then + AssignSt.Free; + end; + end + else + begin + Call:=CreateCallExpression(El); + Elements:=Call.Args.Elements; + try + // s[index] -> s.charAt(index-1) + // add string accessor + DotExpr:=TJSDotMemberExpression(CreateElement(TJSDotMemberExpression,El)); + Call.Expr:=DotExpr; + DotExpr.MExpr:=ConvertElement(El.Value,AContext); + DotExpr.Name:='charAt'; + + // add parameter "index-1" + Expr:=TJSAdditiveExpressionMinus(CreateElement(TJSAdditiveExpressionMinus,Param)); + Elements.AddElement.Expr:=Expr; + Expr.A:=ConvertElement(Param,ArgContext); + Expr.B:=TJSLiteral(CreateElement(TJSLiteral,Param)); + TJSLiteral(Expr.B).Value.AsNumber:=1; + Result:=Call; + finally + if Result=nil then + Call.Free; + end; + end; end; procedure ConvertArray(ArrayEl: TPasArrayType); @@ -1919,7 +2040,7 @@ var // add parameter OldIsWrite:=ArgContext.IsWrite; ArgContext.IsWrite:=false; - Arg:=ConvertElement(El.Params[0],ArgContext); + Arg:=ConvertElement(El.Params[ArgNo],ArgContext); ArgContext.IsWrite:=OldIsWrite; if B.Name<>nil then begin @@ -1944,7 +2065,7 @@ var end; end; - procedure ConvertIndexProperty(Prop: TPasProperty); + procedure ConvertIndexProperty(Prop: TPasProperty; AContext: TConvertContext); var Call: TJSCallExpression; i: Integer; @@ -1975,7 +2096,7 @@ var end else AccessEl:=AContext.Resolver.GetPasPropertyGetter(Prop); - Name:=CreateReferencePath(AccessEl,AContext,rpkPathAndName); + Name:=CreateReferencePath(AccessEl,AContext,rpkPathAndName,false,GetValueReference); Call.Expr:=CreateBuiltInIdentifierExpr(Name); Elements:=Call.Args.Elements; @@ -2026,6 +2147,34 @@ var end; end; + procedure ConvertDefaultProperty(Prop: TPasProperty); + var + OldIsWrite: Boolean; + DotContext: TDotContext; + Left, Right: TJSElement; + begin + DotContext:=nil; + Left:=nil; + Right:=nil; + try + OldIsWrite:=AContext.IsWrite; + AContext.IsWrite:=false; + Left:=ConvertElement(El.Value,AContext); + AContext.IsWrite:=OldIsWrite; + + DotContext:=TDotContext.Create(El.Value,Left,AContext); + AContext.Resolver.ComputeElement(El.Value,DotContext.LeftResolved,[rcReturnFuncResult]); + ConvertIndexProperty(Prop,DotContext); + Right:=Result; + Result:=nil; + finally + DotContext.Free; + if Right=nil then + Left.Free; + end; + Result:=CreateDotExpression(El,Left,Right); + end; + Var OldIsWrite: Boolean; ResolvedEl: TPasResolverResult; @@ -2040,6 +2189,7 @@ begin ArgContext:=ArgContext.Parent; if AContext.Resolver=nil then begin + // without Resolver if Length(El.Params)<>1 then RaiseNotSupported(El,AContext,20170207151325,'Cannot convert 2-dim arrays'); B:=TJSBracketMemberExpression(CreateElement(TJSBracketMemberExpression,El)); @@ -2072,7 +2222,7 @@ begin ConvertStringBracket else if (ResolvedEl.IdentEl is TPasProperty) and (TPasProperty(ResolvedEl.IdentEl).Args.Count>0) then - ConvertIndexProperty(TPasProperty(ResolvedEl.IdentEl)) + ConvertIndexProperty(TPasProperty(ResolvedEl.IdentEl),AContext) else if ResolvedEl.BaseType=btContext then begin TypeEl:=ResolvedEl.TypeEl; @@ -2081,14 +2231,14 @@ begin ClassScope:=TypeEl.CustomData as TPasClassScope; if ClassScope.DefaultProperty=nil then RaiseInconsistency(20170206180448); - ConvertIndexProperty(ClassScope.DefaultProperty); + ConvertDefaultProperty(ClassScope.DefaultProperty); end else if TypeEl.ClassType=TPasClassOfType then begin ClassScope:=TPasClassOfType(TypeEl).DestType.CustomData as TPasClassScope; if ClassScope.DefaultProperty=nil then RaiseInconsistency(20170206180503); - ConvertIndexProperty(ClassScope.DefaultProperty); + ConvertDefaultProperty(ClassScope.DefaultProperty); end else if TypeEl.ClassType=TPasArrayType then ConvertArray(TPasArrayType(TypeEl)) @@ -2135,7 +2285,9 @@ begin bfInclude: Result:=ConvertBuiltInInclude(El,AContext); bfExclude: Result:=ConvertBuiltInExclude(El,AContext); bfExit: Result:=ConvertBuiltInExit(El,AContext); - bfInc,bfDec: Result:=ConvertBuiltInIncDec(El,AContext); + bfInc, + bfDec: Result:=ConvertBuiltInIncDec(El,AContext); + bfAssigned: Result:=ConvertBuiltInAssigned(El,AContext); bfOrd: Result:=ConvertBuiltInOrd(El,AContext); bfLow: Result:=ConvertBuiltInLow(El,AContext); bfHigh: Result:=ConvertBuiltInHigh(El,AContext); @@ -2152,7 +2304,7 @@ begin TargetProc:=TPasProcedure(Decl) else if Decl is TPasEnumType then begin - // EnumType(value) -> value + // enum typecast: EnumType(value) -> value Result:=ConvertElement(El.Params[0],AContext); exit; end; @@ -2481,6 +2633,29 @@ begin end; end; +function TPasToJSConverter.ConvertBuiltInAssigned(El: TParamsExpr; + AContext: TConvertContext): TJSElement; +// convert Assigned(value) -> value!=null +var + NE: TJSEqualityExpressionNE; + Param: TPasExpr; +begin + Result:=nil; + if AContext.Resolver=nil then + RaiseInconsistency(20170210105235); + Param:=El.Params[0]; + NE:=TJSEqualityExpressionNE(CreateElement(TJSEqualityExpressionNE,El)); + try + NE.A:=ConvertElement(Param,AContext); + NE.B:=TJSLiteral(CreateElement(TJSLiteral,El)); + TJSLiteral(NE.B).Value.IsNull:=true; + Result:=NE; + finally + if Result=nil then + NE.Free; + end; +end; + function TPasToJSConverter.ConvertBuiltInOrd(El: TParamsExpr; AContext: TConvertContext): TJSElement; // ord(enum) -> enum @@ -2858,7 +3033,7 @@ begin // create 'this.A=initvalue' AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); Result:=AssignSt; - AssignSt.LHS:=CreateSubNameExpression(El,El.Name,AContext); + AssignSt.LHS:=CreateDeclNameExpression(El,El.Name,AContext); AssignSt.Expr:=CreateVarInit(El,AContext); end else @@ -2900,7 +3075,7 @@ begin // create 'this.A=initvalue' AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); Result:=AssignSt; - AssignSt.LHS:=CreateSubNameExpression(El,El.Name,AContext); + AssignSt.LHS:=CreateDeclNameExpression(El,El.Name,AContext); AssignSt.Expr:=CreateVarInit(El,AContext); end; end; @@ -2985,10 +3160,11 @@ Var E : TJSElement; SLFirst, SLLast: TJSStatementList; P: TPasElement; - IsTopLvl, IsProcBody, IsFunction: boolean; + IsTopLvl, IsProcBody, IsFunction, IsAssembler: boolean; I : Integer; PasProc: TPasProcedure; ProcScope: TPasProcedureScope; + ProcBody: TPasImplBlock; Procedure Add(NewEl: TJSElement); begin @@ -3051,8 +3227,9 @@ begin IsTopLvl:=AContext.IsSingleton; IsProcBody:=(El is TProcedureBody) and (TProcedureBody(El).Body<>nil); IsFunction:=IsProcBody and (El.Parent is TPasFunction); + IsAssembler:=IsProcBody and (TProcedureBody(El).Body is TPasImplAsmStatement); - if IsProcBody and IsFunction then + if IsFunction and not IsAssembler then AddFunctionResultInit; For I:=0 to El.Declarations.Count-1 do @@ -3088,13 +3265,17 @@ begin Add(E); end; - if IsProcBody and (TProcedureBody(El).Body.Elements.Count>0) then + if IsProcBody then begin - E:=ConvertElement(TProcedureBody(El).Body,aContext); - Add(E); + ProcBody:=TProcedureBody(El).Body; + if (ProcBody.Elements.Count>0) or IsAssembler then + begin + E:=ConvertElement(TProcedureBody(El).Body,aContext); + Add(E); + end; end; - if IsProcBody and IsFunction then + if IsFunction and not IsAssembler then AddFunctionResultReturn; end; @@ -3425,7 +3606,7 @@ begin begin // add 'this.TypeName = function(){}' AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); - AssignSt.LHS:=CreateSubNameExpression(El,El.Name,AContext); + AssignSt.LHS:=CreateDeclNameExpression(El,El.Name,AContext); AssignSt.Expr:=Obj; Result:=AssignSt; end; @@ -3540,6 +3721,38 @@ begin Exclude(FOptions,coSwitchStatement); end; +procedure TPasToJSConverter.AddElementData(Data: TPas2JsElementData); +begin + Data.Owner:=Self; + if FFirstElementData<>nil then + begin + FLastElementData.Next:=Data; + FLastElementData:=Data; + end + else + begin + FFirstElementData:=Data; + FLastElementData:=Data; + end; +end; + +function TPasToJSConverter.CreateElementData(DataClass: TPas2JsElementDataClass; + El: TPasElementBase): TPas2JsElementData; +begin + while El.CustomData is TPasElementBase do + El:=TPasElementBase(El.CustomData); + if El.CustomData<>nil then + begin + {$IFDEF VerbosePas2JS} + writeln('TPasToJSConverter.CreateElementData El=',El.ClassName,' El.CustomData=',El.CustomData.ClassName); + {$ENDIF} + RaiseInconsistency(20170212012945); + end; + Result:=DataClass.Create; + Result.Element:=El; + AddElementData(Result); +end; + constructor TPasToJSConverter.Create; begin FOptions:=[coLowerCase]; @@ -3549,6 +3762,7 @@ begin FFuncNameLength:=DefaultFuncNameLength; FFuncNameNewClassInstance:=DefaultFuncNameNewClassInstance; FFuncNameSetArrayLength:=DefaultFuncNameSetArrayLength; + FFuncNameSetCharAt:=DefaultFuncNameSetCharAt; FFuncNameSetStringLength:=DefaultFuncNameSetStringLength; FFuncNameSet_Clone:=DefaultFuncNameSet_Clone; FFuncNameSet_Create:=DefaultFuncNameSet_Create; @@ -3564,6 +3778,28 @@ begin FVarNameLoopEnd:=DefaultVarNameLoopEnd; FVarNameModules:=DefaultVarNameModules; FVarNameRTL:=DefaultVarNameRTL; + FVarNameWith:=DefaultVarNameWith; +end; + +destructor TPasToJSConverter.Destroy; +begin + ClearElementData; + inherited Destroy; +end; + +procedure TPasToJSConverter.ClearElementData; +var + Data, Next: TPas2JsElementData; +begin + Data:=FFirstElementData; + while Data<>nil do + begin + Next:=Data.Next; + Data.Free; + Data:=Next; + end; + FFirstElementData:=nil; + FLastElementData:=nil; end; function TPasToJSConverter.ConvertProcedure(El: TPasProcedure; @@ -3590,6 +3826,27 @@ begin writeln('TPasToJSConverter.ConvertProcedure "',El.Name,'" ',El.Parent.ClassName); {$ENDIF} + // calling convention + if El.CallingConvention<>ccDefault then + DoError(20170211214731,nPasElementNotSupported,sPasElementNotSupported, + [cCallingConventions[El.CallingConvention]],El); + + if pmExternal in El.Modifiers then + begin + // + if El.LibraryExpr<>nil then + DoError(20170211220712,nPasElementNotSupported,sPasElementNotSupported, + ['library'],El.LibraryExpr); + if El.LibrarySymbolName<>nil then + begin + if (El.LibrarySymbolName.ClassType<>TPrimitiveExpr) + or (TPrimitiveExpr(El.LibrarySymbolName).Kind<>pekString) + or (TPrimitiveExpr(El.LibrarySymbolName).Value='') then + DoError(20170211221121,nExpectedXButFoundY,sExpectedXButFoundY,['string literal',El.Name],El); + end; + exit; + end; + DeclProc:=El; ImplProc:=El; ProcScope:=TPasProcedureScope(El.CustomData); @@ -3606,8 +3863,9 @@ begin for pm in TProcedureModifiers do if (pm in DeclProc.Modifiers) and (not (pm in [pmVirtual, pmAbstract, pmOverride, - pmOverload, pmReintroduce, pmForward])) then - RaiseNotSupported(DeclProc,AContext,20170208142159,'modifer '+ModifierNames[pm]); + pmAssembler, + pmOverload, pmReintroduce, pmForward])) then + RaiseNotSupported(DeclProc,AContext,20170208142159,'modifier '+ModifierNames[pm]); AssignSt:=nil; if AContext.IsSingleton then @@ -4004,6 +4262,80 @@ begin raise Exception.Create('TPasToJSConverter.ConvertInitializationSection: finalization section is not supported'); end; +function TPasToJSConverter.CreateDotExpression(aParent: TPasElement; Left, + Right: TJSElement): TJSElement; +var + Dot: TJSDotMemberExpression; + RightParent: TJSElement; + ok: Boolean; +begin + Result:=nil; + if Left=nil then + RaiseInconsistency(20170201140827); + if Right=nil then + RaiseInconsistency(20170211192018); + ok:=false; + try + // create a TJSDotMemberExpression of Left and the left-most identifier of Right + // Left becomes the new left-most element of Right. + Result:=Right; + RightParent:=nil; + repeat + if (Right.ClassType=TJSCallExpression) then + begin + RightParent:=Right; + Right:=TJSCallExpression(Right).Expr; + end + else if (Right.ClassType=TJSBracketMemberExpression) then + begin + RightParent:=Right; + Right:=TJSBracketMemberExpression(Right).MExpr; + end + else if (Right.ClassType=TJSDotMemberExpression) then + begin + RightParent:=Right; + Right:=TJSDotMemberExpression(Right).MExpr; + end + else if (Right.ClassType=TJSPrimaryExpressionIdent) then + begin + // left-most identifier found + // -> replace it + Dot := TJSDotMemberExpression(CreateElement(TJSDotMemberExpression, aParent)); + if Result=Right then + Result:=Dot + else if RightParent is TJSDotMemberExpression then + TJSDotMemberExpression(RightParent).MExpr:=Dot + else if RightParent is TJSCallExpression then + TJSCallExpression(RightParent).Expr:=Dot + else + begin + Dot.Free; + DoError(20170129141307,''); + end; + Dot.MExpr := Left; + Dot.Name := TJSPrimaryExpressionIdent(Right).Name; + FreeAndNil(Right); + break; + end + else + begin + {$IFDEF VerbosePas2JS} + writeln('CreateDotExpression Right=',Right.ClassName); + {$ENDIF} + DoError(20161024191240,nMemberExprMustBeIdentifier,sMemberExprMustBeIdentifier,[],aParent); + end; + until false; + + ok:=true; + finally + if not ok then + begin + Left.Free; + FreeAndNil(Result); + end; + end; +end; + function TPasToJSConverter.ConvertImplBlock(El: TPasImplBlock; AContext: TConvertContext): TJSElement; @@ -4478,42 +4810,101 @@ end; function TPasToJSConverter.ConvertWithStatement(El: TPasImplWithDo; AContext: TConvertContext): TJSElement; - Var - B,E : TJSElement; + B,E , Expr: TJSElement; W,W2 : TJSWithStatement; I : Integer; ok: Boolean; + PasExpr: TPasElement; + V: TJSVariableStatement; + VarDecl: TJSVarDeclaration; + FuncContext: TFunctionContext; + FirstSt, LastSt: TJSStatementList; + WithScope: TPasWithScope; + WithExprScope: TPasWithExprScope; + WithData: TP2JWithData; begin - W:=Nil; - Result:=Nil; - if Assigned(El.Body) then - B:=ConvertElement(El.Body,AContext) + Result:=nil; + if AContext.Resolver<>nil then + begin + // with Resolver: + // Insert for each expression a local var. Example: + // with aPoint do X:=3; + // convert to + // var $with1 = aPoint; + // $with1.X = 3; + FuncContext:=TFunctionContext(AContext.GetContextOfType(TFunctionContext)); + if FuncContext=nil then + RaiseInconsistency(20170212003759); + FirstSt:=nil; + LastSt:=nil; + try + WithScope:=El.CustomData as TPasWithScope; + for i:=0 to El.Expressions.Count-1 do + begin + PasExpr:=TPasElement(El.Expressions[i]); + Expr:=ConvertElement(PasExpr,AContext); + + // create unique local var name + WithExprScope:=TPasWithExprScope(WithScope.ExpressionScopes[i]); + WithData:=TP2JWithData(CreateElementData(TP2JWithData,WithExprScope)); + WithData.WithVarName:=FuncContext.CreateTmpIdentifier(String(VarNameWith)); + // create local "var $with1 = expr;" + V:=TJSVariableStatement(CreateElement(TJSVariableStatement,PasExpr)); + VarDecl:=TJSVarDeclaration(CreateElement(TJSVarDeclaration,PasExpr)); + V.A:=VarDecl; + VarDecl.Name:=WithData.WithVarName; + VarDecl.Init:=Expr; + AddToStatementList(FirstSt,LastSt,V,PasExpr); + end; + if Assigned(El.Body) then + begin + B:=ConvertElement(El.Body,AContext); + AddToStatementList(FirstSt,LastSt,B,El.Body); + end + else + begin + B:=TJSEmptyBlockStatement(CreateElement(TJSEmptyBlockStatement,El)); + AddToStatementList(FirstSt,LastSt,B,El); + end; + Result:=FirstSt; + finally + if Result=nil then + FreeAndNil(FirstSt); + end; + end else - B:=TJSEmptyBlockStatement(CreateElement(TJSEmptyBlockStatement,El)); - ok:=false; - try - For I:=0 to El.Expressions.Count-1 do - begin - E:=ConvertElement(TPasElement(El.Expressions[i]),AContext); - W2:=TJSWithStatement(CreateElement(TJSWithStatement,TPasElement(El.Expressions[i]))); - if Not Assigned(Result) then // result is the first - Result:=W2; - if Assigned(W) then // Chain - W.B:=W2; - W:=W2; // W is the last - W.A:=E; - end; - ok:=true; - finally - if not ok then - begin - FreeAndNil(E); - FreeAndNil(Result); - end; - end; - W.B:=B; + begin + // without Resolver use as fallback the JavaScript with(){} + W:=Nil; + if Assigned(El.Body) then + B:=ConvertElement(El.Body,AContext) + else + B:=TJSEmptyBlockStatement(CreateElement(TJSEmptyBlockStatement,El)); + ok:=false; + try + For I:=0 to El.Expressions.Count-1 do + begin + E:=ConvertElement(TPasElement(El.Expressions[i]),AContext); + W2:=TJSWithStatement(CreateElement(TJSWithStatement,TPasElement(El.Expressions[i]))); + if Not Assigned(Result) then // result is the first + Result:=W2; + if Assigned(W) then // Chain + W.B:=W2; + W:=W2; // W is the last + W.A:=E; + end; + ok:=true; + finally + if not ok then + begin + FreeAndNil(E); + FreeAndNil(Result); + end; + end; + W.B:=B; + end; end; function TPasToJSConverter.GetExceptionObjectName(AContext: TConvertContext @@ -4744,7 +5135,7 @@ begin begin // empty list -> skip if TJSStatementList(Add).B<>nil then - raise Exception.Create('internal error: AddToStatementList add list A=nil, B<>nil'); + raise Exception.Create('internal error: AddToStatementList add list A=nil, B<>nil, B='+TJSStatementList(Add).B.ClassName); FreeAndNil(Add); end else if Last=nil then @@ -4913,10 +5304,11 @@ begin end; function TPasToJSConverter.CreateReferencePath(El: TPasElement; - AContext: TConvertContext; Kind: TRefPathKind; Full: boolean): string; + AContext: TConvertContext; Kind: TRefPathKind; Full: boolean; + Ref: TResolvedReference): string; { Notes: - local var, even higher lvl does not need a reference path - - 'this: + - 'this': - in interface function (even nested) 'this' is the interface, - in implementation function (even nested) 'this' is the implementation, - in initialization 'this' is interface @@ -4964,6 +5356,7 @@ var This, ParentEl: TPasElement; Dot: TDotContext; ThisContext: TFunctionContext; + WithData: TP2JWithData; begin Result:=''; //writeln('TPasToJSConverter.CreateReferencePath START El=',GetObjName(El),' Parent=',GetObjName(El.Parent),' Context=',GetObjName(AContext)); @@ -4992,6 +5385,12 @@ begin end; end; end + else if (Ref<>nil) and (Ref.WithExprScope<>nil) then + begin + // using local with var + WithData:=Ref.WithExprScope.CustomData as TP2JWithData; + Prepend(Result,WithData.WithVarName); + end else if IsLocalVar then begin // El is local var -> does not need path @@ -5326,6 +5725,9 @@ begin Result:=nil; RaiseNotSupported(El, AContext, 20161024190449); end; + {$IFDEF VerbosePas2JS} + writeln('TPasToJSConverter.ConvertElement END ',GetObjName(El)); + {$ENDIF} end; function TPasToJSConverter.ConvertRecordType(El: TPasRecordType; @@ -5373,7 +5775,7 @@ begin begin // add 'this.TypeName = function(){}' AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); - AssignSt.LHS:=CreateSubNameExpression(El,El.Name,AContext); + AssignSt.LHS:=CreateDeclNameExpression(El,El.Name,AContext); AssignSt.Expr:=FDS; end; FD:=TJSFuncDef.Create; diff --git a/packages/pastojs/tests/tcconverter.pp b/packages/pastojs/tests/tcconverter.pp index efe0d144db..eb185585db 100644 --- a/packages/pastojs/tests/tcconverter.pp +++ b/packages/pastojs/tests/tcconverter.pp @@ -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; diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 50cf417e07..9d2360d5de 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -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.