From cbdd7e892f4866abf650d53e5e38a37691c02d01 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Sun, 3 Mar 2019 21:44:42 +0000 Subject: [PATCH] fcl-passrc: parse and resolve method modifier message git-svn-id: trunk@41582 - --- packages/fcl-passrc/src/pasresolveeval.pas | 4 +-- packages/fcl-passrc/src/pasresolver.pp | 20 ++++++++++++ packages/fcl-passrc/src/pastree.pp | 3 ++ packages/fcl-passrc/src/pparser.pp | 27 ++++++++------- packages/fcl-passrc/tests/tcresolver.pas | 38 ++++++++++++++++++++++ 5 files changed, 78 insertions(+), 14 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolveeval.pas b/packages/fcl-passrc/src/pasresolveeval.pas index a99e217233..bd9420ce85 100644 --- a/packages/fcl-passrc/src/pasresolveeval.pas +++ b/packages/fcl-passrc/src/pasresolveeval.pas @@ -181,7 +181,7 @@ const nDerivedXMustExtendASubClassY = 3115; nDefaultPropertyNotAllowedInHelperForX = 3116; nHelpersCannotBeUsedAsTypes = 3117; - // free 3118 + nMessageHandlersInvalidParams = 3118; nImplictConversionUnicodeToAnsi = 3119; nWrongTypeXInArrayConstructor = 3120; nUnknownCustomAttributeX = 3121; @@ -315,7 +315,7 @@ resourcestring sDerivedXMustExtendASubClassY = 'Derived %s must extend a subclass of "%s" or the class itself'; sDefaultPropertyNotAllowedInHelperForX = 'Default property not allowed in helper for %s'; sHelpersCannotBeUsedAsTypes = 'helpers cannot be used as types'; - // was 3118 + sMessageHandlersInvalidParams = 'Message handlers can take only one call by ref. parameter'; sImplictConversionUnicodeToAnsi = 'Implicit string type conversion with potential data loss from "UnicodeString" to "AnsiString"'; sWrongTypeXInArrayConstructor = 'Wrong type "%s" in array constructor'; sUnknownCustomAttributeX = 'Unknown custom attribute "%s"'; diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 9f1037503d..f85bb6f86d 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -5847,6 +5847,8 @@ var ObjKind: TPasObjKind; ParentBody: TProcedureBody; HelperForType: TPasType; + Args: TFPList; + Arg: TPasArgument; begin if El.Parent is TPasProcedure then Proc:=TPasProcedure(El.Parent) @@ -6046,10 +6048,28 @@ begin if El is TPasFunctionType then EmitTypeHints(TPasFunctionType(El).ResultEl,TPasFunctionType(El).ResultEl.ResultType); + if Proc.PublicName<>nil then + ResolveExpr(Proc.PublicName,rraRead); if Proc.LibraryExpr<>nil then ResolveExpr(Proc.LibraryExpr,rraRead); if Proc.LibrarySymbolName<>nil then ResolveExpr(Proc.LibrarySymbolName,rraRead); + if Proc.DispIDExpr<>nil then + ResolveExpr(Proc.DispIDExpr,rraRead); + if Proc.MessageExpr<>nil then + begin + // message modifier + ResolveExpr(Proc.MessageExpr,rraRead); + Args:=Proc.ProcType.Args; + if Args.Count<>1 then + RaiseMsg(20190303223701,nMessageHandlersInvalidParams,sMessageHandlersInvalidParams,[],El); + Arg:=TPasArgument(Args[0]); + if not (Arg.Access in [argVar,argOut]) then + RaiseMsg(20190303223834,nMessageHandlersInvalidParams,sMessageHandlersInvalidParams,[],El); + if (Proc.ClassType<>TPasProcedure) + and (Proc.ClassType<>TPasFunction) then + RaiseMsg(20190303224128,nXExpectedButYFound,sXExpectedButYFound,['procedure name(var Msg);message id;',GetElementTypeName(El)],El); + end; if Proc.Parent is TPasMembersType then begin diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index 3a024fc88a..af8c0c7499 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -1054,6 +1054,7 @@ type LibrarySymbolName, LibraryExpr : TPasExpr; // e.g. external LibraryExpr name LibrarySymbolName; DispIDExpr : TPasExpr; + MessageExpr: TPasExpr; AliasName : String; ProcType : TPasProcedureType; Body : TProcedureBody; @@ -3398,6 +3399,7 @@ begin ReleaseAndNil(TPasElement(LibraryExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.LibraryExpr'{$ENDIF}); ReleaseAndNil(TPasElement(LibrarySymbolName){$IFDEF CheckPasTreeRefCount},'TPasProcedure.LibrarySymbolName'{$ENDIF}); ReleaseAndNil(TPasElement(DispIDExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.DispIDExpr'{$ENDIF}); + ReleaseAndNil(TPasElement(MessageExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.MessageExpr'{$ENDIF}); ReleaseAndNil(TPasElement(ProcType){$IFDEF CheckPasTreeRefCount},'TPasProcedure.ProcType'{$ENDIF}); ReleaseAndNil(TPasElement(Body){$IFDEF CheckPasTreeRefCount},'TPasProcedure.Body'{$ENDIF}); inherited Destroy; @@ -4472,6 +4474,7 @@ begin ForEachChildCall(aMethodCall,Arg,PublicName,false); ForEachChildCall(aMethodCall,Arg,LibraryExpr,false); ForEachChildCall(aMethodCall,Arg,LibrarySymbolName,false); + ForEachChildCall(aMethodCall,Arg,MessageExpr,false); ForEachChildCall(aMethodCall,Arg,Body,false); end; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index fd9d759006..57569c9dee 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -4866,21 +4866,24 @@ begin end; pmMessage: begin - Repeat - NextToken; - If CurToken<>tkSemicolon then - begin - if Parent is TPasProcedure then - TPasProcedure(Parent).MessageName:=CurtokenString; - If (CurToken=tkString) and (Parent is TPasProcedure) then - TPasProcedure(Parent).Messagetype:=pmtString; - end; - until CurToken = tkSemicolon; - UngetToken; + NextToken; + E:=DoParseExpression(Parent); + TPasProcedure(Parent).MessageExpr:=E; + if E is TPrimitiveExpr then + begin + TPasProcedure(Parent).MessageName:=TPrimitiveExpr(E).Value; + case E.Kind of + pekNumber, pekUnary: TPasProcedure(Parent).Messagetype:=pmtInteger; + pekString: TPasProcedure(Parent).Messagetype:=pmtString; + end; + end; + if CurToken = tkSemicolon then + UngetToken; end; pmDispID: begin - TPasProcedure(Parent).DispIDExpr:=DoParseExpression(Parent,Nil); + NextToken; + TPasProcedure(Parent).DispIDExpr:=DoParseExpression(Parent); if CurToken = tkSemicolon then UngetToken; end; diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 9c19725b07..328fe6258b 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -620,6 +620,8 @@ type Procedure TestClass_EnumeratorFunc; Procedure TestClass_ForInPropertyStaticArray; Procedure TestClass_TypeAlias; + Procedure TestClass_Message; + Procedure TestClass_Message_MissingParamFail; // published Procedure TestClass_PublishedClassVarFail; @@ -11118,6 +11120,42 @@ begin ParseProgram; end; +procedure TTestResolver.TestClass_Message; +begin + StartProgram(false); + Add([ + 'const', + ' FlyId = 2;', + ' RunStr = ''Fast'';', + 'type', + ' TObject = class', + ' procedure Fly(var msg); message 3+FlyId;', + ' procedure Run(var msg); virtual; abstract; message ''prefix''+RunStr;', + ' end;', + 'procedure TObject.Fly(var msg);', + 'begin', + 'end;', + 'begin', + '']); + ParseProgram; +end; + +procedure TTestResolver.TestClass_Message_MissingParamFail; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class', + ' procedure Fly; message 3;', + ' end;', + 'procedure TObject.Fly;', + 'begin', + 'end;', + 'begin', + '']); + CheckResolverException(sMessageHandlersInvalidParams,nMessageHandlersInvalidParams); +end; + procedure TTestResolver.TestClass_PublishedClassVarFail; begin StartProgram(false);