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

fcl-passrc: parse and resolve method modifier message

Browse Source 
git-svn-id: trunk@41582 -
This commit is contained in:
Mattias Gaertner 2019-03-03 21:44:42 +00:00
parent 72196141b0
commit cbdd7e892f
5 changed files with 78 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -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"';

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

@ -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

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

@ -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;

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

@ -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;

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

@ -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);