From 23e7ced10064ab1f2b90d630101d63c65c0c9d1e Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Tue, 19 May 2020 12:42:25 +0000 Subject: [PATCH] fcl-passrc: fixed parsing case statement without semicolon before else, added comments git-svn-id: trunk@45432 - --- packages/fcl-passrc/src/pparser.pp | 182 +++++++++++++-------------- packages/pastojs/src/fppas2js.pp | 9 +- packages/pastojs/src/pas2jsfiler.pp | 6 +- packages/pastojs/tests/tcmodules.pas | 57 +++++++++ 4 files changed, 153 insertions(+), 101 deletions(-) diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 7e5ff6386d..668954a89e 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -453,7 +453,7 @@ type procedure ParseInitialization; procedure ParseFinalization; procedure ParseDeclarations(Declarations: TPasDeclarations); - procedure ParseStatement(Parent: TPasImplBlock; out NewImplElement: TPasImplElement); + procedure ParseStatement(Parent: TPasImplBlock; out NewImplElement: TPasImplElement); procedure ParseLabels(AParent: TPasElement); procedure ParseProcBeginBlock(Parent: TProcedureBody); procedure ParseProcAsmBlock(Parent: TProcedureBody); @@ -5809,7 +5809,7 @@ var begin if CurBlock=Parent then exit(true); while CurBlock.CloseOnSemicolon - or (CloseIfs and (CurBlock is TPasImplIfElse)) do + or (CloseIfs and (CurBlock is TPasImplIfElse)) do if CloseBlock then exit(true); Result:=false; end; @@ -5821,19 +5821,20 @@ var if NewImplElement=nil then NewImplElement:=CurBlock; end; - procedure CheckSemicolon; + procedure CheckStatementCanStart; var t: TToken; begin - if (CurBlock.Elements.Count=0) then exit; + if (CurBlock.Elements.Count=0) then + exit; // at start of block t:=GetPrevToken; - if t in [tkSemicolon,tkColon] then - exit; - if (CurBlock.ClassType=TPasImplIfElse) and (t=tkelse) then - exit; + case t of + tkSemicolon,tkColon,tkElse: exit; + end; {$IFDEF VerbosePasParser} writeln('TPasParser.ParseStatement.CheckSemicolon Prev=',GetPrevToken,' Cur=',CurToken,' ',CurBlock.ClassName,' ',CurBlock.Elements.Count,' ',TObject(CurBlock.Elements[0]).ClassName); {$ENDIF} + // last statement not complete -> semicolon is missing ParseExcTokenError('Semicolon'); end; @@ -5867,11 +5868,11 @@ begin while True do begin NextToken; - //WriteLn({$IFDEF VerbosePasParser}i,{$ENDIF}' Token=',CurTokenText); + //WriteLn({$IFDEF VerbosePasParser}i,{$ENDIF}' Token=',CurTokenText,' CurBlock=',CurBlock.ClassName); case CurToken of tkasm: begin - CheckSemicolon; + CheckStatementCanStart; El:=TPasImplElement(CreateElement(TPasImplAsmStatement,'',CurBlock,CurTokenPos)); ParseAsmBlock(TPasImplAsmStatement(El)); CurBlock.AddElement(El); @@ -5882,98 +5883,84 @@ begin end; tkbegin: begin - CheckSemicolon; + CheckStatementCanStart; El:=TPasImplElement(CreateElement(TPasImplBeginBlock,'',CurBlock,CurTokenPos)); CreateBlock(TPasImplBeginBlock(El)); El:=nil; end; tkrepeat: begin - CheckSemicolon; + CheckStatementCanStart; El:=TPasImplRepeatUntil(CreateElement(TPasImplRepeatUntil,'',CurBlock,CurTokenPos)); CreateBlock(TPasImplRepeatUntil(El)); El:=nil; end; tkIf: begin - CheckSemicolon; - SrcPos:=CurTokenPos; - NextToken; - Left:=DoParseExpression(CurBlock); - UngetToken; - El:=TPasImplIfElse(CreateElement(TPasImplIfElse,'',CurBlock,SrcPos)); - TPasImplIfElse(El).ConditionExpr:=Left; - Left.Parent:=El; - Left:=nil; - //WriteLn(i,'IF Condition="',Condition,'" Token=',CurTokenText); - CreateBlock(TPasImplIfElse(El)); - El:=nil; - ExpectToken(tkthen); + CheckStatementCanStart; + SrcPos:=CurTokenPos; + NextToken; + Left:=DoParseExpression(CurBlock); + UngetToken; + El:=TPasImplIfElse(CreateElement(TPasImplIfElse,'',CurBlock,SrcPos)); + TPasImplIfElse(El).ConditionExpr:=Left; + Left.Parent:=El; + Left:=nil; + //WriteLn(i,'IF Condition="',Condition,'" Token=',CurTokenText); + CreateBlock(TPasImplIfElse(El)); + El:=nil; + ExpectToken(tkthen); end; tkelse: - if (CurBlock is TPasImplIfElse) then - begin - if TPasImplIfElse(CurBlock).IfBranch=nil then - begin - // empty then statement e.g. if condition then else - El:=TPasImplCommand(CreateElement(TPasImplCommand,'', CurBlock,CurTokenPos)); - CurBlock.AddElement(El); - El:=nil; - end; - if TPasImplIfElse(CurBlock).ElseBranch<>nil then - begin - // this and the following 3 may solve TPasImplIfElse.AddElement BUG - // ifs without begin end - // if .. then - // if .. then - // else - // else + // ELSE can close multiple blocks, similar to semicolon + repeat + {$IFDEF VerbosePasParser} + writeln('TPasParser.ParseStatement CurBlock=',CurBlock.ClassName); + {$ENDIF} + if CurBlock is TPasImplIfElse then + begin + if TPasImplIfElse(CurBlock).IfBranch=nil then + begin + // empty THEN statement e.g. if condition then else + El:=TPasImplCommand(CreateElement(TPasImplCommand,'', CurBlock,CurTokenPos)); + CurBlock.AddElement(El); // this sets TPasImplIfElse(CurBlock).IfBranch:=El + El:=nil; + end; + if TPasImplIfElse(CurBlock).ElseBranch=nil then + break; // add next statement as ElseBranch + end + else if CurBlock is TPasImplTryExcept then + begin + // close TryExcept handler and open an TryExceptElse handler CloseBlock; - CloseStatement(false); - end; - end else if (CurBlock is TPasImplCaseStatement) then - begin - // Case ... else without semicolon in front. - UngetToken; - CloseStatement(False); - break; - end else if (CurBlock is TPasImplWhileDo) then - begin + El:=TPasImplTryExceptElse(CreateElement(TPasImplTryExceptElse,'',CurBlock,CurTokenPos)); + TPasImplTry(CurBlock).ElseBranch:=TPasImplTryExceptElse(El); + CurBlock:=TPasImplTryExceptElse(El); + El:=nil; + break; + end + else if (CurBlock is TPasImplCaseStatement) then + begin + UngetToken; + // Note: a TPasImplCaseStatement is parsed by a call of ParseStatement, + // so it must be the top level block + if CurBlock<>Parent then + CheckToken(tkSemicolon); + exit; + end + else if (CurBlock is TPasImplWhileDo) + or (CurBlock is TPasImplForLoop) + or (CurBlock is TPasImplWithDo) + or (CurBlock is TPasImplRaise) then + // simply close block + else + ParseExcSyntaxError; CloseBlock; - UngetToken; - end else if (CurBlock is TPasImplForLoop) then - begin - //if .. then for .. do smt else .. - CloseBlock; - UngetToken; - end else if (CurBlock is TPasImplWithDo) then - begin - //if .. then with .. do smt else .. - CloseBlock; - UngetToken; - end else if (CurBlock is TPasImplRaise) then - begin - //if .. then Raise Exception else .. - CloseBlock; - UngetToken; - end else if (CurBlock is TPasImplAsmStatement) then - begin - //if .. then asm end else .. - CloseBlock; - UngetToken; - end else if (CurBlock is TPasImplTryExcept) then - begin - CloseBlock; - El:=TPasImplTryExceptElse(CreateElement(TPasImplTryExceptElse,'',CurBlock,CurTokenPos)); - TPasImplTry(CurBlock).ElseBranch:=TPasImplTryExceptElse(El); - CurBlock:=TPasImplTryExceptElse(El); - El:=nil; - end else - ParseExcSyntaxError; + until false; tkwhile: begin // while Condition do - CheckSemicolon; + CheckStatementCanStart; SrcPos:=CurTokenPos; NextToken; Left:=DoParseExpression(CurBlock); @@ -5989,7 +5976,7 @@ begin end; tkgoto: begin - CheckSemicolon; + CheckStatementCanStart; NextToken; CurBlock.AddCommand('goto '+curtokenstring); // expecttoken(tkSemiColon); @@ -5998,7 +5985,7 @@ begin begin // for VarName := StartValue to EndValue do // for VarName in Expression do - CheckSemicolon; + CheckStatementCanStart; El:=TPasImplForLoop(CreateElement(TPasImplForLoop,'',CurBlock,CurTokenPos)); ExpectIdentifier; Expr:=CreatePrimitiveExpr(El,pekIdent,CurTokenString); @@ -6051,7 +6038,7 @@ begin begin // with Expr do // with Expr, Expr do - CheckSemicolon; + CheckStatementCanStart; SrcPos:=CurTokenPos; NextToken; El:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock,SrcPos)); @@ -6075,7 +6062,7 @@ begin end; tkcase: begin - CheckSemicolon; + CheckStatementCanStart; SrcPos:=CurTokenPos; NextToken; Left:=DoParseExpression(CurBlock); @@ -6144,15 +6131,14 @@ begin until Curtoken=tkColon; // read statement ParseStatement(CurBlock,SubBlock); + // CurToken is now at last token of case-statement CloseBlock; if CurToken<>tkSemicolon then - begin NextToken; - if not (CurToken in [tkSemicolon,tkelse,tkend]) then - ParseExcTokenError(TokenInfos[tkSemicolon]); - if CurToken<>tkSemicolon then - UngetToken; - end; + if not (CurToken in [tkSemicolon,tkelse,tkend]) then + ParseExcTokenError(TokenInfos[tkSemicolon]); + if CurToken<>tkSemicolon then + UngetToken; end; until false; if CurToken=tkend then @@ -6163,7 +6149,7 @@ begin end; tktry: begin - CheckSemicolon; + CheckStatementCanStart; El:=TPasImplTry(CreateElement(TPasImplTry,'',CurBlock,CurTokenPos)); CreateBlock(TPasImplTry(El)); El:=nil; @@ -6203,7 +6189,7 @@ begin end; tkraise: begin - CheckSemicolon; + CheckStatementCanStart; ImplRaise:=TPasImplRaise(CreateElement(TPasImplRaise,'',CurBlock,CurTokenPos)); CreateBlock(ImplRaise); NextToken; @@ -6223,13 +6209,17 @@ begin end; tkend: begin + // Note: ParseStatement should return with CurToken at last token of the statement if CloseStatement(true) then begin + // there was none requiring an END UngetToken; break; end; + // still a block left if CurBlock is TPasImplBeginBlock then begin + // close at END if CloseBlock then break; // close end if CloseStatement(false) then break; end else if CurBlock is TPasImplCaseElse then @@ -6283,7 +6273,7 @@ begin // Do not check this here: // if (CurToken=tkAt) and not (msDelphi in CurrentModeswitches) then // ParseExc; - CheckSemicolon; + CheckStatementCanStart; // On is usable as an identifier if lowerCase(CurTokenText)='on' then diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 3cfe7180bc..aa64dbb891 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -1238,7 +1238,8 @@ const po_AsmWhole, po_ResolveStandardTypes, po_ExtConstWithoutExpr, - po_StopOnUnitInterface]; + po_StopOnUnitInterface, + po_AsyncProcs]; btAllJSBaseTypes = [ btChar, @@ -4087,7 +4088,8 @@ begin if (not (pm in [pmVirtual, pmAbstract, pmOverride, pmOverload, pmMessage, pmReintroduce, pmInline, pmAssembler, pmPublic, - pmExternal, pmForward])) then + pmExternal, pmForward, + pmAsync])) then RaiseNotYetImplemented(20170208142159,El,'modifier '+ModifierNames[pm]); for ptm in Proc.ProcType.Modifiers do if (not (ptm in [ptmOfObject,ptmVarargs,ptmStatic])) then @@ -4234,7 +4236,7 @@ begin RaiseMsg(20170227095454,nMissingExternalName,sMissingExternalName, ['missing external name'],Proc); - for pm in [pmAssembler,pmForward,pmNoReturn,pmInline] do + for pm in [pmAssembler,pmForward,pmNoReturn,pmInline,pmAsync] do if pm in Proc.Modifiers then RaiseMsg(20170323100842,nInvalidXModifierY,sInvalidXModifierY, [Proc.ElementTypeName,ModifierNames[pm]],Proc); @@ -15052,6 +15054,7 @@ begin FS:=CreateFunctionSt(ImplProc,ImplProc.Body<>nil); FD:=FS.AFunction; + FD.IsAsync:=El.IsAsync or ImplProc.IsAsync; if AssignSt<>nil then AssignSt.Expr:=FS else diff --git a/packages/pastojs/src/pas2jsfiler.pp b/packages/pastojs/src/pas2jsfiler.pp index 60b9f5b018..0fa99b1389 100644 --- a/packages/pastojs/src/pas2jsfiler.pp +++ b/packages/pastojs/src/pas2jsfiler.pp @@ -132,7 +132,8 @@ const 'StopOnErrorDirective', 'ExtClassConstWithoutExpr', 'StopOnUnitInterface', - 'IgnoreUnknownResource'); + 'IgnoreUnknownResource', + 'AsyncProcs'); PCUDefaultModeSwitches: TModeSwitches = [ msObjfpc, @@ -486,7 +487,8 @@ const 'DispId', 'NoReturn', 'Far', - 'Final' + 'Final', + 'Async' ); PCUProcedureModifiersImplProc = [pmInline,pmAssembler,pmCompilerProc,pmNoReturn]; diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 5a526255e9..4920e2b7b0 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -340,6 +340,7 @@ type Procedure TestProc_LocalVarInit; Procedure TestProc_ReservedWords; Procedure TestProc_ConstRefWord; + Procedure TestProc_Async; // anonymous functions Procedure TestAnonymousProc_Assign_ObjFPC; @@ -352,6 +353,7 @@ type Procedure TestAnonymousProc_NestedAssignResult; Procedure TestAnonymousProc_Class; Procedure TestAnonymousProc_ForLoop; + Procedure TestAnonymousProc_Async; // enums, sets Procedure TestEnum_Name; @@ -4604,6 +4606,32 @@ begin ])); end; +procedure TTestModule.TestProc_Async; +begin + StartProgram(false); + Add([ + 'procedure Fly(w: word); async; forward;', + 'procedure Run(w: word); async;', + 'begin', + 'end;', + 'procedure Fly(w: word); ', + 'begin', + 'end;', + 'begin', + ' Run(1);']); + ConvertProgram; + CheckSource('TestProc_Async', + LinesToStr([ // statements + 'this.Run = async function (w) {', + '};', + 'this.Fly = async function (w) {', + '};', + '']), + LinesToStr([ + '$mod.Run(1);' + ])); +end; + procedure TTestModule.TestAnonymousProc_Assign_ObjFPC; begin StartProgram(false); @@ -5083,6 +5111,35 @@ begin ])); end; +procedure TTestModule.TestAnonymousProc_Async; +begin + StartProgram(false); + Add([ + '{$mode objfpc}', + 'type', + ' TFunc = reference to function(x: word): word;', + 'var Func: TFunc;', + 'begin', + ' Func:=function(c:word):word async begin', + ' end;', + ' Func:=function(c:word):word async assembler asm', + ' end;', + ' ']); + ConvertProgram; + CheckSource('TestAnonymousProc_Async', + LinesToStr([ // statements + 'this.Func = null;', + '']), + LinesToStr([ + '$mod.Func = async function (c) {', + ' var Result = 0;', + ' return Result;', + '};', + '$mod.Func = async function (c) {', + '};', + ''])); +end; + procedure TTestModule.TestEnum_Name; begin StartProgram(false);