paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-14 10:29:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: started anonymous methods

Browse Source 
git-svn-id: trunk@40475 -
This commit is contained in:
Mattias Gaertner 2018-12-06 09:32:49 +00:00
parent b82026dcf8
commit 0fe9e24297
4 changed files with 631 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1824,6 +1824,7 @@ type
function GetPasPropertyStoredExpr(El: TPasProperty): TPasExpr; function GetPasPropertyStoredExpr(El: TPasProperty): TPasExpr;
function GetPasPropertyDefaultExpr(El: TPasProperty): TPasExpr; function GetPasPropertyDefaultExpr(El: TPasProperty): TPasExpr;
function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType; function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType;
function GetParentProcBody(El: TPasElement): TProcedureBody;
function ProcHasImplElements(Proc: TPasProcedure): boolean; virtual; function ProcHasImplElements(Proc: TPasProcedure): boolean; virtual;
function IndexOfImplementedInterface(ClassEl: TPasClassType; aType: TPasType): integer; function IndexOfImplementedInterface(ClassEl: TPasClassType; aType: TPasType): integer;
function GetLoop(El: TPasElement): TPasImplElement; function GetLoop(El: TPasElement): TPasImplElement;
@ -2072,8 +2073,8 @@ begin
dec(Indent,2); dec(Indent,2);
end; end;
Result:=Result+')'; Result:=Result+')';
if El is TPasFunction then if (El is TPasProcedure) and (TPasProcedure(El).ProcType is TPasFunctionType) then
Result:=Result+':'+GetTreeDbg(TPasFunctionType(TPasFunction(El).ProcType).ResultEl,Indent); Result:=Result+':'+GetTreeDbg(TPasFunctionType(TPasProcedure(El).ProcType).ResultEl,Indent);
if TPasProcedureType(El).IsOfObject then if TPasProcedureType(El).IsOfObject then
Result:=Result+' '+ProcTypeModifiers[ptmOfObject]; Result:=Result+' '+ProcTypeModifiers[ptmOfObject];
if TPasProcedureType(El).IsNested then if TPasProcedureType(El).IsNested then
@ -2273,6 +2274,10 @@ begin
Result:='class procedure' Result:='class procedure'
else if C=TPasClassFunction then else if C=TPasClassFunction then
Result:='class function' Result:='class function'
else if C=TPasAnonymousProcedure then
Result:='anonymous procedure'
else if C=TPasAnonymousFunction then
Result:='anonymous function'
else if C=TPasMethodResolution then else if C=TPasMethodResolution then
Result:='method resolution' Result:='method resolution'
else if C=TInterfaceSection then else if C=TInterfaceSection then
@ -5310,13 +5315,17 @@ var
pm: TProcedureModifier; pm: TProcedureModifier;
ptm: TProcTypeModifier; ptm: TProcTypeModifier;
ObjKind: TPasObjKind; ObjKind: TPasObjKind;
ParentBody: TProcedureBody;
begin begin
if (El.Parent is TPasProcedure) and (TPasProcedure(El.Parent).ProcType=El) then if El.Parent is TPasProcedure then
Proc:=TPasProcedure(El.Parent)
else
Proc:=nil;
if (Proc<>nil) and (Proc.ProcType=El) then
begin begin
// finished header of a procedure declaration // finished header of a procedure declaration
// -> search the best fitting proc // -> search the best fitting proc
CheckTopScope(FScopeClass_Proc); CheckTopScope(FScopeClass_Proc);
Proc:=TPasProcedure(El.Parent);
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishProcedureHeader El=',GetTreeDbg(El),' ',GetElementSourcePosStr(El),' IsForward=',Proc.IsForward,' Parent=',GetObjName(El.Parent)); writeln('TPasResolver.FinishProcedureHeader El=',GetTreeDbg(El),' ',GetElementSourcePosStr(El),' IsForward=',Proc.IsForward,' Parent=',GetObjName(El.Parent));
{$ENDIF} {$ENDIF}
@ -5325,13 +5334,14 @@ begin
if (proProcTypeWithoutIsNested in Options) and El.IsNested then if (proProcTypeWithoutIsNested in Options) and El.IsNested then
RaiseInvalidProcTypeModifier(20170402120811,El,ptmIsNested,El); RaiseInvalidProcTypeModifier(20170402120811,El,ptmIsNested,El);
if (Proc.Parent.ClassType=TProcedureBody) then ParentBody:=GetParentProcBody(Proc.Parent);
if (ParentBody<>nil) then
begin begin
// nested sub proc // nested sub proc
if not (proProcTypeWithoutIsNested in Options) then if not (proProcTypeWithoutIsNested in Options) then
El.IsNested:=true; El.IsNested:=true;
// inherit 'of Object' // inherit 'of Object'
ParentProc:=Proc.Parent.Parent as TPasProcedure; ParentProc:=ParentBody.Parent as TPasProcedure;
if ParentProc.ProcType.IsOfObject then if ParentProc.ProcType.IsOfObject then
El.IsOfObject:=true; El.IsOfObject:=true;
end; end;
@ -5393,7 +5403,7 @@ begin
end end
else else
begin begin
// intf proc, forward proc, proc body, method body // intf proc, forward proc, proc body, method body, anonymous proc
if Proc.IsAbstract then if Proc.IsAbstract then
RaiseInvalidProcModifier(20170216151634,Proc,pmAbstract,Proc); RaiseInvalidProcModifier(20170216151634,Proc,pmAbstract,Proc);
if Proc.IsVirtual then if Proc.IsVirtual then
@ -5405,8 +5415,12 @@ begin
if Proc.IsStatic then if Proc.IsStatic then
RaiseInvalidProcTypeModifier(20170216151640,El,ptmStatic,El); RaiseInvalidProcTypeModifier(20170216151640,El,ptmStatic,El);
if (not HasDots) if (not HasDots)
and (Proc.ClassType<>TPasProcedure) and (Proc.GetProcTypeEnum in [
and (Proc.ClassType<>TPasFunction) then ptClassOperator,
ptConstructor, ptDestructor,
ptClassProcedure, ptClassFunction,
ptClassConstructor, ptClassDestructor
]) then
RaiseXExpectedButYFound(20170419232724,'full method name','short name',El); RaiseXExpectedButYFound(20170419232724,'full method name','short name',El);
end; end;
@ -5418,7 +5432,8 @@ begin
// finish interface/implementation/nested procedure/method declaration // finish interface/implementation/nested procedure/method declaration
if not IsValidIdent(ProcName) then if not (Proc.GetProcTypeEnum in [ptAnonymousProcedure,ptAnonymousFunction])
and not IsValidIdent(ProcName) then
RaiseNotYetImplemented(20160922163407,El); RaiseNotYetImplemented(20160922163407,El);
if El is TPasFunctionType then if El is TPasFunctionType then
@ -5436,7 +5451,7 @@ begin
end; end;
// finish interface/implementation/nested procedure // finish interface/implementation/nested procedure
if ProcNeedsBody(Proc) then if (ProcName<>'') and ProcNeedsBody(Proc) then
begin begin
// check if there is a forward declaration // check if there is a forward declaration
ParentScope:=Scopes[ScopeCount-2]; ParentScope:=Scopes[ScopeCount-2];
@ -5483,13 +5498,16 @@ begin
StoreScannerFlagsInProc(ProcScope); StoreScannerFlagsInProc(ProcScope);
end; end;
// check for invalid overloads if ProcName<>'' then
FindData:=Default(TFindOverloadProcData); begin
FindData.Proc:=Proc; // check for invalid overloads
FindData.Args:=Proc.ProcType.Args; FindData:=Default(TFindOverloadProcData);
FindData.Kind:=fopkProc; FindData.Proc:=Proc;
Abort:=false; FindData.Args:=Proc.ProcType.Args;
IterateElements(ProcName,@OnFindOverloadProc,@FindData,Abort); FindData.Kind:=fopkProc;
Abort:=false;
IterateElements(ProcName,@OnFindOverloadProc,@FindData,Abort);
end;
end end
else if El.Name<>'' then else if El.Name<>'' then
begin begin
@ -6836,12 +6854,12 @@ begin
else else
RaiseNotYetImplemented(20170203161826,ImplProc); RaiseNotYetImplemented(20170203161826,ImplProc);
end; end;
if DeclProc is TPasFunction then if DeclProc.ProcType is TPasFunctionType then
begin begin
// redirect implementation 'Result' to declaration FuncType.ResultEl // redirect implementation 'Result' to declaration FuncType.ResultEl
Identifier:=ImplProcScope.FindLocalIdentifier(ResolverResultVar); Identifier:=ImplProcScope.FindLocalIdentifier(ResolverResultVar);
if Identifier.Element is TPasResultElement then if Identifier.Element is TPasResultElement then
Identifier.Element:=TPasFunction(DeclProc).FuncType.ResultEl; Identifier.Element:=TPasFunctionType(DeclProc.ProcType).ResultEl;
end; end;
end; end;
@ -6899,11 +6917,11 @@ begin
RaiseXExpectedButYFound(20170216151729,DeclProc.TypeName,ImplProc.TypeName,ImplProc); RaiseXExpectedButYFound(20170216151729,DeclProc.TypeName,ImplProc.TypeName,ImplProc);
if ImplProc.CallingConvention<>DeclProc.CallingConvention then if ImplProc.CallingConvention<>DeclProc.CallingConvention then
RaiseMsg(20170216151731,nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc); RaiseMsg(20170216151731,nCallingConventionMismatch,sCallingConventionMismatch,[],ImplProc);
if ImplProc is TPasFunction then if ImplProc.ProcType is TPasFunctionType then
begin begin
// check result type // check result type
ImplResult:=TPasFunction(ImplProc).FuncType.ResultEl.ResultType; ImplResult:=TPasFunctionType(ImplProc.ProcType).ResultEl.ResultType;
DeclResult:=TPasFunction(DeclProc).FuncType.ResultEl.ResultType; DeclResult:=TPasFunctionType(DeclProc.ProcType).ResultEl.ResultType;
if not CheckElTypeCompatibility(ImplResult,DeclResult,prraSimple) then if not CheckElTypeCompatibility(ImplResult,DeclResult,prraSimple) then
RaiseIncompatibleType(20170216151734,nResultTypeMismatchExpectedButFound, RaiseIncompatibleType(20170216151734,nResultTypeMismatchExpectedButFound,
@ -7827,6 +7845,7 @@ begin
[],El); [],El);
ResolveRecordValues(TRecordValues(El)); ResolveRecordValues(TRecordValues(El));
end end
else if ElClass=TProcedureExpr then
else else
RaiseNotYetImplemented(20170222184329,El); RaiseNotYetImplemented(20170222184329,El);
@ -7882,7 +7901,7 @@ begin
begin begin
// examples: funca or @proca or a.funca or @a.funca ... // examples: funca or @proca or a.funca or @a.funca ...
Proc:=TPasProcedure(DeclEl); Proc:=TPasProcedure(DeclEl);
if (Access=rraAssign) and (Proc is TPasFunction) if (Access=rraAssign) and (Proc.ProcType is TPasFunctionType)
and (El.ClassType=TPrimitiveExpr) and (El.ClassType=TPrimitiveExpr)
and (El.Parent.ClassType=TPasImplAssign) and (El.Parent.ClassType=TPasImplAssign)
and (TPasImplAssign(El.Parent).left=El) then and (TPasImplAssign(El.Parent).left=El) then
@ -7895,7 +7914,7 @@ begin
if El.HasParent(ImplProc) then if El.HasParent(ImplProc) then
begin begin
// "FuncA:=" within FuncA -> redirect to ResultEl // "FuncA:=" within FuncA -> redirect to ResultEl
Ref.Declaration:=(Proc as TPasFunction).FuncType.ResultEl; Ref.Declaration:=TPasFunctionType(Proc.ProcType).ResultEl;
exit; exit;
end; end;
end; end;
@ -8499,7 +8518,7 @@ var
if DeclEl is TPasProcedure then if DeclEl is TPasProcedure then
begin begin
Proc:=TPasProcedure(DeclEl); Proc:=TPasProcedure(DeclEl);
if (Access=rraAssign) and (Proc is TPasFunction) if (Access=rraAssign) and (Proc.ProcType is TPasFunctionType)
and (Value.ClassType=TPrimitiveExpr) and (Value.ClassType=TPrimitiveExpr)
and (Params.Parent.ClassType=TPasImplAssign) and (Params.Parent.ClassType=TPasImplAssign)
and (TPasImplAssign(Params.Parent).left=Params) then and (TPasImplAssign(Params.Parent).left=Params) then
@ -8512,7 +8531,7 @@ var
if Params.HasParent(ImplProc) then if Params.HasParent(ImplProc) then
begin begin
// "FuncA[]:=" within FuncA -> redirect to ResultEl // "FuncA[]:=" within FuncA -> redirect to ResultEl
Ref.Declaration:=(Proc as TPasFunction).FuncType.ResultEl; Ref.Declaration:=TPasFunctionType(Proc.ProcType).ResultEl;
end; end;
end; end;
end; end;
@ -8930,7 +8949,8 @@ begin
else if (Access in [rraRead,rraParamToUnknownProc]) else if (Access in [rraRead,rraParamToUnknownProc])
and ((C=TPrimitiveExpr) and ((C=TPrimitiveExpr)
or (C=TNilExpr) or (C=TNilExpr)
or (C=TBoolConstExpr)) then or (C=TBoolConstExpr)
or (C=TProcedureExpr)) then
// ok // ok
else if C=TUnaryExpr then else if C=TUnaryExpr then
AccessExpr(TUnaryExpr(Expr).Operand,Access) AccessExpr(TUnaryExpr(Expr).Operand,Access)
@ -9350,10 +9370,10 @@ begin
{$ENDIF} {$ENDIF}
if not (TopScope is TPasIdentifierScope) then if not (TopScope is TPasIdentifierScope) then
RaiseInvalidScopeForElement(20160922163522,El); RaiseInvalidScopeForElement(20160922163522,El);
// Note: El.ProcType is nil ! // Note: El.ProcType is nil ! It is parsed later.
ProcName:=El.Name; ProcName:=El.Name;
HasDot:=Pos('.',ProcName)>1; HasDot:=Pos('.',ProcName)>1;
if not HasDot then if (not HasDot) and (ProcName<>'') then
AddIdentifier(TPasIdentifierScope(TopScope),ProcName,El,pikProc); AddIdentifier(TPasIdentifierScope(TopScope),ProcName,El,pikProc);
ProcScope:=TPasProcedureScope(PushScope(El,FScopeClass_Proc)); ProcScope:=TPasProcedureScope(PushScope(El,FScopeClass_Proc));
ProcScope.ModeSwitches:=CurrentParser.CurrentModeswitches; ProcScope.ModeSwitches:=CurrentParser.CurrentModeswitches;
@ -9420,7 +9440,7 @@ begin
ProcScope.VisibilityContext:=CurClassType; ProcScope.VisibilityContext:=CurClassType;
ProcScope.ClassScope:=NoNil(CurClassType.CustomData) as TPasClassScope; ProcScope.ClassScope:=NoNil(CurClassType.CustomData) as TPasClassScope;
end; end;// HasDot=true
end; end;
procedure TPasResolver.AddArgument(El: TPasArgument); procedure TPasResolver.AddArgument(El: TPasArgument);
@ -10500,9 +10520,9 @@ begin
Proc:=TPasProcedure(ResolvedEl.IdentEl); Proc:=TPasProcedure(ResolvedEl.IdentEl);
if rcConstant in Flags then if rcConstant in Flags then
RaiseConstantExprExp(20170216152637,Params); RaiseConstantExprExp(20170216152637,Params);
if Proc is TPasFunction then if Proc.ProcType is TPasFunctionType then
// function call => return result // function call => return result
ComputeElement(TPasFunction(Proc).FuncType.ResultEl,ResolvedEl, ComputeElement(TPasFunctionType(Proc.ProcType).ResultEl,ResolvedEl,
Flags+[rcNoImplicitProc],StartEl) Flags+[rcNoImplicitProc],StartEl)
else if (Proc.ClassType=TPasConstructor) else if (Proc.ClassType=TPasConstructor)
and (rrfNewInstance in Ref.Flags) then and (rrfNewInstance in Ref.Flags) then
@ -12498,6 +12518,7 @@ var
ProcScope: TPasProcedureScope; ProcScope: TPasProcedureScope;
ResultEl: TPasResultElement; ResultEl: TPasResultElement;
Flags: TPasResolverComputeFlags; Flags: TPasResolverComputeFlags;
CtxProc: TPasProcedure;
begin begin
if (not (Expr is TParamsExpr)) or (length(TParamsExpr(Expr).Params)=0) then if (not (Expr is TParamsExpr)) or (length(TParamsExpr(Expr).Params)=0) then
exit(cExact); exit(cExact);
@ -12515,14 +12536,15 @@ begin
begin begin
// first param is function result // first param is function result
ProcScope:=TPasProcedureScope(Scopes[i]); ProcScope:=TPasProcedureScope(Scopes[i]);
if not (ProcScope.Element is TPasFunction) then CtxProc:=TPasProcedure(ProcScope.Element);
if not (CtxProc.ProcType is TPasFunctionType) then
begin begin
if RaiseOnError then if RaiseOnError then
RaiseMsg(20170216152312,nWrongNumberOfParametersForCallTo, RaiseMsg(20170216152312,nWrongNumberOfParametersForCallTo,
sWrongNumberOfParametersForCallTo,['procedure exit'],Params.Params[0]); sWrongNumberOfParametersForCallTo,['procedure exit'],Params.Params[0]);
exit(cIncompatible); exit(cIncompatible);
end; end;
ResultEl:=(ProcScope.Element as TPasFunction).FuncType.ResultEl; ResultEl:=TPasFunctionType(CtxProc.ProcType).ResultEl;
ComputeElement(ResultEl,ResultResolved,[rcType]); ComputeElement(ResultEl,ResultResolved,[rcType]);
end end
else else
@ -12937,9 +12959,9 @@ begin
begin begin
Expr:=TPasVariable(ParamResolved.IdentEl).Expr; Expr:=TPasVariable(ParamResolved.IdentEl).Expr;
if Expr is TArrayValues then if Expr is TArrayValues then
Evaluated:=TResEvalInt.CreateValue(length(TArrayValues(Expr).Values)-1) Evaluated:=TResEvalInt.CreateValue(TMaxPrecInt(length(TArrayValues(Expr).Values))-1)
else if (Expr is TParamsExpr) and (TParamsExpr(Expr).Kind=pekSet) then else if (Expr is TParamsExpr) and (TParamsExpr(Expr).Kind=pekSet) then
Evaluated:=TResEvalInt.CreateValue(length(TParamsExpr(Expr).Params)-1); Evaluated:=TResEvalInt.CreateValue(TMaxPrecInt(length(TParamsExpr(Expr).Params))-1);
if Evaluated=nil then if Evaluated=nil then
RaiseXExpectedButYFound(20170601191003,'array constant','expression',Params); RaiseXExpectedButYFound(20170601191003,'array constant','expression',Params);
end end
@ -13635,8 +13657,9 @@ begin
aType:=TPasArgument(Decl).ArgType aType:=TPasArgument(Decl).ArgType
else if Decl.ClassType=TPasResultElement then else if Decl.ClassType=TPasResultElement then
aType:=TPasResultElement(Decl).ResultType aType:=TPasResultElement(Decl).ResultType
else if Decl is TPasFunction then else if (Decl is TPasProcedure)
aType:=TPasFunction(Decl).FuncType.ResultEl.ResultType; and (TPasProcedure(Decl).ProcType is TPasFunctionType) then
aType:=TPasFunctionType(TPasProcedure(Decl).ProcType).ResultEl.ResultType;
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
{AllowWriteln} {AllowWriteln}
if aType=nil then if aType=nil then
@ -16446,7 +16469,7 @@ begin
begin begin
EnumType:=TPasEnumType(LTypeEl); EnumType:=TPasEnumType(LTypeEl);
LRangeValue:=TResEvalRangeInt.CreateValue(revskEnum,EnumType, LRangeValue:=TResEvalRangeInt.CreateValue(revskEnum,EnumType,
0,EnumType.Values.Count-1); 0,TMaxPrecInt(EnumType.Values.Count)-1);
end end
else if C=TPasUnresolvedSymbolRef then else if C=TPasUnresolvedSymbolRef then
begin begin
@ -17047,7 +17070,15 @@ begin
if CheckProcTypeCompatibility(TPasProcedureType(LHS.LoTypeEl), if CheckProcTypeCompatibility(TPasProcedureType(LHS.LoTypeEl),
TPasProcedure(RHS.IdentEl).ProcType,true,ErrorEl,RaiseOnIncompatible) then TPasProcedure(RHS.IdentEl).ProcType,true,ErrorEl,RaiseOnIncompatible) then
exit(cExact); exit(cExact);
end; end
else if (LHS.LoTypeEl is TPasProcedureType)
and (RHS.ExprEl is TProcedureExpr) then
begin
// for example ProcVar:=anonymous-procedure...
if CheckProcTypeCompatibility(TPasProcedureType(LHS.LoTypeEl),
TProcedureExpr(RHS.ExprEl).Proc.ProcType,true,ErrorEl,RaiseOnIncompatible) then
exit(cExact);
end
end end
else if LBT=btPointer then else if LBT=btPointer then
begin begin
@ -19846,7 +19877,7 @@ begin
begin begin
TypeEl:=TPasProcedure(El).ProcType; TypeEl:=TPasProcedure(El).ProcType;
SetResolverIdentifier(ResolvedEl,btProc,El,TypeEl,TypeEl,[rrfCanBeStatement]); SetResolverIdentifier(ResolvedEl,btProc,El,TypeEl,TypeEl,[rrfCanBeStatement]);
if El is TPasFunction then if TPasProcedure(El).ProcType is TPasFunctionType then
Include(ResolvedEl.Flags,rrfReadable); Include(ResolvedEl.Flags,rrfReadable);
// Note: the readability of TPasConstructor depends on the context // Note: the readability of TPasConstructor depends on the context
// Note: implicit calls are handled in TPrimitiveExpr // Note: implicit calls are handled in TPrimitiveExpr
@ -19857,6 +19888,11 @@ begin
TPasProcedureType(El),TPasProcedureType(El),[rrfCanBeStatement]); TPasProcedureType(El),TPasProcedureType(El),[rrfCanBeStatement]);
// Note: implicit calls are handled in TPrimitiveExpr // Note: implicit calls are handled in TPrimitiveExpr
end end
else if ElClass=TProcedureExpr then
begin
TypeEl:=TProcedureExpr(El).Proc.ProcType;
SetResolverValueExpr(ResolvedEl,btProc,TypeEl,TypeEl,TProcedureExpr(El),[rrfReadable]);
end
else if ElClass=TPasArrayType then else if ElClass=TPasArrayType then
SetResolverIdentifier(ResolvedEl,btContext,El,TPasArrayType(El),TPasArrayType(El),[]) SetResolverIdentifier(ResolvedEl,btContext,El,TPasArrayType(El),TPasArrayType(El),[])
else if ElClass=TArrayValues then else if ElClass=TArrayValues then
@ -20001,6 +20037,17 @@ begin
end; end;
end; end;
function TPasResolver.GetParentProcBody(El: TPasElement): TProcedureBody;
begin
while El<>nil do
begin
if El is TProcedureBody then
exit(TProcedureBody(El));
El:=El.Parent;
end;
Result:=nil;
end;
function TPasResolver.ProcHasImplElements(Proc: TPasProcedure): boolean; function TPasResolver.ProcHasImplElements(Proc: TPasProcedure): boolean;
begin begin
Result:=GetProcFirstImplEl(Proc)<>nil; Result:=GetProcFirstImplEl(Proc)<>nil;
@ -20558,7 +20605,7 @@ begin
else if C=TPasEnumType then else if C=TPasEnumType then
begin begin
Result:=TResEvalRangeInt.CreateValue(revskEnum,TPasEnumType(Decl), Result:=TResEvalRangeInt.CreateValue(revskEnum,TPasEnumType(Decl),
0,TPasEnumType(Decl).Values.Count-1); 0,TMaxPrecInt(TPasEnumType(Decl).Values.Count)-1);
Result.IdentEl:=Decl; Result.IdentEl:=Decl;
exit; exit;
end end

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

@ -82,6 +82,8 @@ resourcestring
SPasTreeClassDestructor = 'class destructor'; SPasTreeClassDestructor = 'class destructor';
SPasTreeConstructor = 'constructor'; SPasTreeConstructor = 'constructor';
SPasTreeDestructor = 'destructor'; SPasTreeDestructor = 'destructor';
SPasTreeAnonymousProcedure = 'anonymous procedure';
SPasTreeAnonymousFunction = 'anonymous function';
SPasTreeProcedureImpl = 'procedure/function implementation'; SPasTreeProcedureImpl = 'procedure/function implementation';
SPasTreeConstructorImpl = 'constructor implementation'; SPasTreeConstructorImpl = 'constructor implementation';
SPasTreeDestructorImpl = 'destructor implementation'; SPasTreeDestructorImpl = 'destructor implementation';
@ -192,7 +194,7 @@ type
TPasExprKind = (pekIdent, pekNumber, pekString, pekSet, pekNil, pekBoolConst, TPasExprKind = (pekIdent, pekNumber, pekString, pekSet, pekNil, pekBoolConst,
pekRange, pekUnary, pekBinary, pekFuncParams, pekArrayParams, pekListOfExp, pekRange, pekUnary, pekBinary, pekFuncParams, pekArrayParams, pekListOfExp,
pekInherited, pekSelf, pekSpecialize); pekInherited, pekSelf, pekSpecialize, pekProcedure);
TExprOpCode = (eopNone, TExprOpCode = (eopNone,
eopAdd,eopSubtract,eopMultiply,eopDivide, eopDiv,eopMod, eopPower,// arithmetic eopAdd,eopSubtract,eopMultiply,eopDivide, eopDiv,eopMod, eopPower,// arithmetic
@ -969,7 +971,8 @@ type
ptOperator, ptClassOperator, ptOperator, ptClassOperator,
ptConstructor, ptDestructor, ptConstructor, ptDestructor,
ptClassProcedure, ptClassFunction, ptClassProcedure, ptClassFunction,
ptClassConstructor, ptClassDestructor); ptClassConstructor, ptClassDestructor,
ptAnonymousProcedure, ptAnonymousFunction);
{ TPasProcedureBase } { TPasProcedureBase }
@ -1004,6 +1007,8 @@ type
TProcedureBody = class; TProcedureBody = class;
{ TPasProcedure - named procedure, not anonymous }
TPasProcedure = class(TPasProcedureBase) TPasProcedure = class(TPasProcedureBase)
Private Private
FModifiers : TProcedureModifiers; FModifiers : TProcedureModifiers;
@ -1020,13 +1025,13 @@ type
procedure ForEachCall(const aMethodCall: TOnForEachPasElement; procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override; const Arg: Pointer); override;
public public
ProcType : TPasProcedureType;
Body : TProcedureBody;
PublicName, // e.g. public PublicName; PublicName, // e.g. public PublicName;
LibrarySymbolName, LibrarySymbolName,
LibraryExpr : TPasExpr; // e.g. external LibraryExpr name LibrarySymbolName; LibraryExpr : TPasExpr; // e.g. external LibraryExpr name LibrarySymbolName;
DispIDExpr : TPasExpr; DispIDExpr : TPasExpr;
AliasName : String; AliasName : String;
ProcType : TPasProcedureType;
Body : TProcedureBody;
Procedure AddModifier(AModifier : TProcedureModifier); Procedure AddModifier(AModifier : TProcedureModifier);
Function IsVirtual : Boolean; Function IsVirtual : Boolean;
Function IsDynamic : Boolean; Function IsDynamic : Boolean;
@ -1039,6 +1044,7 @@ type
Function IsReintroduced : Boolean; Function IsReintroduced : Boolean;
Function IsStatic : Boolean; Function IsStatic : Boolean;
Function IsForward: Boolean; Function IsForward: Boolean;
Function GetProcTypeEnum: TProcType; virtual;
Property Modifiers : TProcedureModifiers Read FModifiers Write FModifiers; Property Modifiers : TProcedureModifiers Read FModifiers Write FModifiers;
Property CallingConvention : TCallingConvention Read GetCallingConvention Write SetCallingConvention; Property CallingConvention : TCallingConvention Read GetCallingConvention Write SetCallingConvention;
Property MessageName : String Read FMessageName Write FMessageName; Property MessageName : String Read FMessageName Write FMessageName;
@ -1048,14 +1054,16 @@ type
TArrayOfPasProcedure = array of TPasProcedure; TArrayOfPasProcedure = array of TPasProcedure;
{ TPasFunction - named function, not anonymous function}
TPasFunction = class(TPasProcedure) TPasFunction = class(TPasProcedure)
private private
function GetFT: TPasFunctionType; inline; function GetFT: TPasFunctionType; inline;
public public
function ElementTypeName: string; override; function ElementTypeName: string; override;
function TypeName: string; override; function TypeName: string; override;
function GetDeclaration (full : boolean) : string; override;
Property FuncType : TPasFunctionType Read GetFT; Property FuncType : TPasFunctionType Read GetFT;
function GetProcTypeEnum: TProcType; override;
end; end;
{ TPasOperator } { TPasOperator }
@ -1082,17 +1090,18 @@ type
Function OldName(WithPath : Boolean) : String; Function OldName(WithPath : Boolean) : String;
function ElementTypeName: string; override; function ElementTypeName: string; override;
function TypeName: string; override; function TypeName: string; override;
function GetProcTypeEnum: TProcType; override;
function GetDeclaration (full : boolean) : string; override; function GetDeclaration (full : boolean) : string; override;
Property OperatorType : TOperatorType Read FOperatorType Write FOperatorType; Property OperatorType : TOperatorType Read FOperatorType Write FOperatorType;
// True if the declaration was using a token instead of an identifier // True if the declaration was using a token instead of an identifier
Property TokenBased : Boolean Read FTokenBased Write FTokenBased; Property TokenBased : Boolean Read FTokenBased Write FTokenBased;
end; end;
Type
{ TPasClassOperator } { TPasClassOperator }
TPasClassOperator = class(TPasOperator) TPasClassOperator = class(TPasOperator)
function TypeName: string; override; function TypeName: string; override;
function GetProcTypeEnum: TProcType; override;
end; end;
@ -1102,6 +1111,7 @@ Type
public public
function ElementTypeName: string; override; function ElementTypeName: string; override;
function TypeName: string; override; function TypeName: string; override;
function GetProcTypeEnum: TProcType; override;
end; end;
{ TPasClassConstructor } { TPasClassConstructor }
@ -1110,6 +1120,7 @@ Type
public public
function ElementTypeName: string; override; function ElementTypeName: string; override;
function TypeName: string; override; function TypeName: string; override;
function GetProcTypeEnum: TProcType; override;
end; end;
{ TPasDestructor } { TPasDestructor }
@ -1118,6 +1129,7 @@ Type
public public
function ElementTypeName: string; override; function ElementTypeName: string; override;
function TypeName: string; override; function TypeName: string; override;
function GetProcTypeEnum: TProcType; override;
end; end;
{ TPasClassDestructor } { TPasClassDestructor }
@ -1126,6 +1138,7 @@ Type
public public
function ElementTypeName: string; override; function ElementTypeName: string; override;
function TypeName: string; override; function TypeName: string; override;
function GetProcTypeEnum: TProcType; override;
end; end;
{ TPasClassProcedure } { TPasClassProcedure }
@ -1134,6 +1147,7 @@ Type
public public
function ElementTypeName: string; override; function ElementTypeName: string; override;
function TypeName: string; override; function TypeName: string; override;
function GetProcTypeEnum: TProcType; override;
end; end;
{ TPasClassFunction } { TPasClassFunction }
@ -1142,8 +1156,43 @@ Type
public public
function ElementTypeName: string; override; function ElementTypeName: string; override;
function TypeName: string; override; function TypeName: string; override;
function GetProcTypeEnum: TProcType; override;
end; end;
{ TPasAnonymousProcedure - parent is TProcedureExpr }
TPasAnonymousProcedure = class(TPasProcedure)
public
function ElementTypeName: string; override;
function TypeName: string; override;
function GetProcTypeEnum: TProcType; override;
end;
{ TPasAnonymousFunction - parent is TProcedureExpr and ProcType is TPasFunctionType}
TPasAnonymousFunction = class(TPasAnonymousProcedure)
private
function GetFT: TPasFunctionType; inline;
public
function ElementTypeName: string; override;
function TypeName: string; override;
Property FuncType : TPasFunctionType Read GetFT;
function GetProcTypeEnum: TProcType; override;
end;
{ TProcedureExpr }
TProcedureExpr = class(TPasExpr)
public
Proc: TPasAnonymousProcedure;
constructor Create(AParent: TPasElement); overload;
destructor Destroy; override;
function GetDeclaration(full: Boolean): string; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override;
end;
TPasImplBlock = class; TPasImplBlock = class;
{ TProcedureBody - the var+type+const+begin, without the header, child of TPasProcedure } { TProcedureBody - the var+type+const+begin, without the header, child of TPasProcedure }
@ -1577,7 +1626,8 @@ const
'ListOfExp', 'ListOfExp',
'Inherited', 'Inherited',
'Self', 'Self',
'Specialize'); 'Specialize',
'Procedure');
OpcodeStrings : Array[TExprOpCode] of string = ( OpcodeStrings : Array[TExprOpCode] of string = (
'','+','-','*','/','div','mod','**', '','+','-','*','/','div','mod','**',
@ -1643,6 +1693,26 @@ begin
El:=nil; El:=nil;
end; end;
Function IndentStrings(S : TStrings; indent : Integer) : string;
Var
I,CurrLen,CurrPos : Integer;
begin
Result:='';
CurrLen:=0;
CurrPos:=0;
For I:=0 to S.Count-1 do
begin
CurrLen:=Length(S[i]);
If (CurrLen+CurrPos)>72 then
begin
Result:=Result+LineEnding+StringOfChar(' ',Indent);
CurrPos:=Indent;
end;
Result:=Result+S[i];
CurrPos:=CurrPos+CurrLen;
end;
end;
{$IFDEF HasPTDumpStack} {$IFDEF HasPTDumpStack}
procedure PTDumpStack; procedure PTDumpStack;
begin begin
@ -1843,6 +1913,11 @@ begin
Result:='class operator'; Result:='class operator';
end; end;
function TPasClassOperator.GetProcTypeEnum: TProcType;
begin
Result:=ptClassOperator;
end;
{ TPasImplAsmStatement } { TPasImplAsmStatement }
constructor TPasImplAsmStatement.Create(const AName: string; constructor TPasImplAsmStatement.Create(const AName: string;
@ -1865,6 +1940,79 @@ begin
Result:='class '+ inherited TypeName; Result:='class '+ inherited TypeName;
end; end;
function TPasClassConstructor.GetProcTypeEnum: TProcType;
begin
Result:=ptClassConstructor;
end;
{ TPasAnonymousProcedure }
function TPasAnonymousProcedure.ElementTypeName: string;
begin
Result:=SPasTreeAnonymousProcedure;
end;
function TPasAnonymousProcedure.TypeName: string;
begin
Result:='anonymous procedure';
end;
function TPasAnonymousProcedure.GetProcTypeEnum: TProcType;
begin
Result:=ptAnonymousProcedure;
end;
{ TPasAnonymousFunction }
function TPasAnonymousFunction.GetFT: TPasFunctionType;
begin
Result:=ProcType as TPasFunctionType;
end;
function TPasAnonymousFunction.ElementTypeName: string;
begin
Result := SPasTreeAnonymousFunction;
end;
function TPasAnonymousFunction.TypeName: string;
begin
Result:='anonymous function';
end;
function TPasAnonymousFunction.GetProcTypeEnum: TProcType;
begin
Result:=ptAnonymousFunction;
end;
{ TProcedureExpr }
constructor TProcedureExpr.Create(AParent: TPasElement);
begin
inherited Create(AParent,pekProcedure, eopNone);
end;
destructor TProcedureExpr.Destroy;
begin
ReleaseAndNil(TPasElement(Proc){$IFDEF CheckPasTreeRefCount},'TProcedureExpr.Proc'{$ENDIF});
inherited Destroy;
end;
function TProcedureExpr.GetDeclaration(full: Boolean): string;
begin
if Proc<>nil then
Result:=Proc.GetDeclaration(full)
else
Result:='procedure-expr';
end;
procedure TProcedureExpr.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer);
begin
inherited ForEachCall(aMethodCall, Arg);
if Proc<>nil then
Proc.ForEachCall(aMethodCall,Arg);
end;
{ TPasImplRaise } { TPasImplRaise }
destructor TPasImplRaise.Destroy; destructor TPasImplRaise.Destroy;
@ -2157,7 +2305,7 @@ begin
Result:=ProcType as TPasFunctionType; Result:=ProcType as TPasFunctionType;
end; end;
function TPasFunction.ElementTypeName: string; begin Result := SPasTreeFunction end; function TPasFunction.ElementTypeName: string; begin Result := SPasTreeFunction; end;
function TPasClassProcedure.ElementTypeName: string; begin Result := SPasTreeClassProcedure; end; function TPasClassProcedure.ElementTypeName: string; begin Result := SPasTreeClassProcedure; end;
function TPasClassConstructor.ElementTypeName: string; begin Result := SPasTreeClassConstructor; end; function TPasClassConstructor.ElementTypeName: string; begin Result := SPasTreeClassConstructor; end;
function TPasClassDestructor.ElementTypeName: string; begin Result := SPasTreeClassDestructor; end; function TPasClassDestructor.ElementTypeName: string; begin Result := SPasTreeClassDestructor; end;
@ -2167,6 +2315,11 @@ begin
Result:='destructor'; Result:='destructor';
end; end;
function TPasClassDestructor.GetProcTypeEnum: TProcType;
begin
Result:=ptClassDestructor;
end;
function TPasClassFunction.ElementTypeName: string; begin Result := SPasTreeClassFunction; end; function TPasClassFunction.ElementTypeName: string; begin Result := SPasTreeClassFunction; end;
class function TPasOperator.OperatorTypeToToken(T: TOperatorType): String; class function TPasOperator.OperatorTypeToToken(T: TOperatorType): String;
@ -3229,12 +3382,12 @@ end;
destructor TPasProcedure.Destroy; destructor TPasProcedure.Destroy;
begin begin
ReleaseAndNil(TPasElement(ProcType){$IFDEF CheckPasTreeRefCount},'TPasProcedure.ProcType'{$ENDIF});
ReleaseAndNil(TPasElement(Body){$IFDEF CheckPasTreeRefCount},'TPasProcedure.Body'{$ENDIF});
ReleaseAndNil(TPasElement(PublicName){$IFDEF CheckPasTreeRefCount},'TPasProcedure.PublicName'{$ENDIF}); ReleaseAndNil(TPasElement(PublicName){$IFDEF CheckPasTreeRefCount},'TPasProcedure.PublicName'{$ENDIF});
ReleaseAndNil(TPasElement(LibraryExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.LibraryExpr'{$ENDIF}); ReleaseAndNil(TPasElement(LibraryExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.LibraryExpr'{$ENDIF});
ReleaseAndNil(TPasElement(LibrarySymbolName){$IFDEF CheckPasTreeRefCount},'TPasProcedure.LibrarySymbolName'{$ENDIF}); ReleaseAndNil(TPasElement(LibrarySymbolName){$IFDEF CheckPasTreeRefCount},'TPasProcedure.LibrarySymbolName'{$ENDIF});
ReleaseAndNil(TPasElement(DispIDExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.DispIDExpr'{$ENDIF}); ReleaseAndNil(TPasElement(DispIDExpr){$IFDEF CheckPasTreeRefCount},'TPasProcedure.DispIDExpr'{$ENDIF});
ReleaseAndNil(TPasElement(ProcType){$IFDEF CheckPasTreeRefCount},'TPasProcedure.ProcType'{$ENDIF});
ReleaseAndNil(TPasElement(Body){$IFDEF CheckPasTreeRefCount},'TPasProcedure.Body'{$ENDIF});
inherited Destroy; inherited Destroy;
end; end;
@ -3764,29 +3917,6 @@ begin
ForEachChildCall(aMethodCall,Arg,ElType,true); ForEachChildCall(aMethodCall,Arg,ElType,true);
end; end;
Function IndentStrings(S : TStrings; indent : Integer) : string;
Var
I,CurrLen,CurrPos : Integer;
begin
Result:='';
CurrLen:=0;
CurrPos:=0;
For I:=0 to S.Count-1 do
begin
CurrLen:=Length(S[i]);
If (CurrLen+CurrPos)>72 then
begin
Result:=Result+LineEnding+StringOfChar(' ',Indent);
CurrPos:=Indent;
end;
Result:=Result+S[i];
CurrPos:=CurrPos+CurrLen;
end;
end;
function TPasEnumType.GetDeclaration (full : boolean) : string; function TPasEnumType.GetDeclaration (full : boolean) : string;
Var Var
@ -4278,8 +4408,8 @@ procedure TPasProcedure.ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); const Arg: Pointer);
begin begin
inherited ForEachCall(aMethodCall, Arg); inherited ForEachCall(aMethodCall, Arg);
ForEachChildCall(aMethodCall,Arg,PublicName,false);
ForEachChildCall(aMethodCall,Arg,ProcType,false); ForEachChildCall(aMethodCall,Arg,ProcType,false);
ForEachChildCall(aMethodCall,Arg,PublicName,false);
ForEachChildCall(aMethodCall,Arg,LibraryExpr,false); ForEachChildCall(aMethodCall,Arg,LibraryExpr,false);
ForEachChildCall(aMethodCall,Arg,LibrarySymbolName,false); ForEachChildCall(aMethodCall,Arg,LibrarySymbolName,false);
ForEachChildCall(aMethodCall,Arg,Body,false); ForEachChildCall(aMethodCall,Arg,Body,false);
@ -4347,36 +4477,28 @@ begin
Result:=pmForward in FModifiers; Result:=pmForward in FModifiers;
end; end;
function TPasProcedure.GetDeclaration(full: Boolean): string; function TPasProcedure.GetProcTypeEnum: TProcType;
Var
S : TStringList;
begin begin
S:=TStringList.Create; Result:=ptProcedure;
try
If Full then
S.Add(TypeName+' '+Name);
ProcType.GetArguments(S);
GetModifiers(S);
Result:=IndentStrings(S,Length(S[0]));
finally
S.Free;
end;
end; end;
function TPasFunction.GetDeclaration (full : boolean) : string; function TPasProcedure.GetDeclaration(full: Boolean): string;
Var Var
S : TStringList; S : TStringList;
T : string; T: String;
begin begin
S:=TStringList.Create; S:=TStringList.Create;
try try
If Full then If Full then
S.Add(TypeName+' '+Name); begin
T:=TypeName;
if Name<>'' then
T:=T+' '+Name;
S.Add(T);
end;
ProcType.GetArguments(S); ProcType.GetArguments(S);
If Assigned((Proctype as TPasFunctionType).ResultEl) then If ProcType is TPasFunctionType
and Assigned(TPasFunctionType(Proctype).ResultEl) then
With TPasFunctionType(ProcType).ResultEl.ResultType do With TPasFunctionType(ProcType).ResultEl.ResultType do
begin begin
T:=' : '; T:=' : ';
@ -4398,6 +4520,11 @@ begin
Result:='function'; Result:='function';
end; end;
function TPasFunction.GetProcTypeEnum: TProcType;
begin
Result:=ptFunction;
end;
function TPasOperator.GetOperatorDeclaration(Full : Boolean) : string; function TPasOperator.GetOperatorDeclaration(Full : Boolean) : string;
begin begin
@ -4450,26 +4577,51 @@ begin
Result:='operator'; Result:='operator';
end; end;
function TPasOperator.GetProcTypeEnum: TProcType;
begin
Result:=ptOperator;
end;
function TPasClassProcedure.TypeName: string; function TPasClassProcedure.TypeName: string;
begin begin
Result:='class procedure'; Result:='class procedure';
end; end;
function TPasClassProcedure.GetProcTypeEnum: TProcType;
begin
Result:=ptClassProcedure;
end;
function TPasClassFunction.TypeName: string; function TPasClassFunction.TypeName: string;
begin begin
Result:='class function'; Result:='class function';
end; end;
function TPasClassFunction.GetProcTypeEnum: TProcType;
begin
Result:=ptClassFunction;
end;
function TPasConstructor.TypeName: string; function TPasConstructor.TypeName: string;
begin begin
Result:='constructor'; Result:='constructor';
end; end;
function TPasConstructor.GetProcTypeEnum: TProcType;
begin
Result:=ptConstructor;
end;
function TPasDestructor.TypeName: string; function TPasDestructor.TypeName: string;
begin begin
Result:='destructor'; Result:='destructor';
end; end;
function TPasDestructor.GetProcTypeEnum: TProcType;
begin
Result:=ptDestructor;
end;
function TPasArgument.GetDeclaration (full : boolean) : string; function TPasArgument.GetDeclaration (full : boolean) : string;
begin begin
If Assigned(ArgType) then If Assigned(ArgType) then

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

@ -314,7 +314,7 @@ type
function ReadDottedIdentifier(Parent: TPasElement; out Expr: TPasExpr; NeedAsString: boolean): String; function ReadDottedIdentifier(Parent: TPasElement; out Expr: TPasExpr; NeedAsString: boolean): String;
function CheckProcedureArgs(Parent: TPasElement; function CheckProcedureArgs(Parent: TPasElement;
Args: TFPList; // list of TPasArgument Args: TFPList; // list of TPasArgument
Mandatory: Boolean): boolean; ProcType: TProcType): boolean;
function CheckVisibility(S: String; var AVisibility: TPasMemberVisibility): Boolean; function CheckVisibility(S: String; var AVisibility: TPasMemberVisibility): Boolean;
procedure ParseExc(MsgNumber: integer; const Msg: String); procedure ParseExc(MsgNumber: integer; const Msg: String);
procedure ParseExc(MsgNumber: integer; const Fmt: String; Args : Array of {$ifdef pas2js}jsvalue{$else}const{$endif}); procedure ParseExc(MsgNumber: integer; const Fmt: String; Args : Array of {$ifdef pas2js}jsvalue{$else}const{$endif});
@ -349,12 +349,15 @@ type
function CreateRecordValues(AParent : TPasElement): TRecordValues; function CreateRecordValues(AParent : TPasElement): TRecordValues;
Function IsCurTokenHint(out AHint : TPasMemberHint) : Boolean; overload; Function IsCurTokenHint(out AHint : TPasMemberHint) : Boolean; overload;
Function IsCurTokenHint: Boolean; overload; Function IsCurTokenHint: Boolean; overload;
Function TokenIsCallingConvention(const S : String; out CC : TCallingConvention) : Boolean; virtual; Function TokenIsCallingConvention(const S: String; out CC : TCallingConvention) : Boolean; virtual;
Function TokenIsProcedureModifier(Parent : TPasElement; const S : String; Out PM : TProcedureModifier) : Boolean; virtual; Function TokenIsProcedureModifier(Parent: TPasElement; const S: String; Out PM : TProcedureModifier): Boolean; virtual;
Function TokenIsAnonymousProcedureModifier(Parent: TPasElement; S: String; Out PM: TProcedureModifier): Boolean; virtual;
Function TokenIsProcedureTypeModifier(Parent : TPasElement; const S : String; Out PTM : TProcTypeModifier) : Boolean; virtual; Function TokenIsProcedureTypeModifier(Parent : TPasElement; const S : String; Out PTM : TProcTypeModifier) : Boolean; virtual;
Function CheckHint(Element : TPasElement; ExpectSemiColon : Boolean) : TPasMemberHints; Function CheckHint(Element : TPasElement; ExpectSemiColon : Boolean) : TPasMemberHints;
function IsAnonymousProcAllowed(El: TPasElement): boolean; virtual;
function ParseParams(AParent : TPasElement; ParamsKind: TPasExprKind; AllowFormatting : Boolean = False): TParamsExpr; function ParseParams(AParent : TPasElement; ParamsKind: TPasExprKind; AllowFormatting : Boolean = False): TParamsExpr;
function ParseExpIdent(AParent : TPasElement): TPasExpr; function ParseExprOperand(AParent : TPasElement): TPasExpr;
function ParseExpIdent(AParent : TPasElement): TPasExpr; deprecated 'use ParseExprOperand instead'; // since fpc 3.3.1
procedure DoParseClassType(AType: TPasClassType); procedure DoParseClassType(AType: TPasClassType);
function DoParseExpression(AParent: TPaselement;InitExpr: TPasExpr=nil; AllowEqual : Boolean = True): TPasExpr; function DoParseExpression(AParent: TPaselement;InitExpr: TPasExpr=nil; AllowEqual : Boolean = True): TPasExpr;
function DoParseConstValueExpression(AParent: TPasElement): TPasExpr; function DoParseConstValueExpression(AParent: TPasElement): TPasExpr;
@ -1241,6 +1244,21 @@ begin
end; end;
end; end;
function TPasParser.TokenIsAnonymousProcedureModifier(Parent: TPasElement;
S: String; out PM: TProcedureModifier): Boolean;
begin
S:=LowerCase(S);
case S of
'assembler':
begin
PM:=pmAssembler;
exit(true);
end;
end;
Result:=false;
if Parent=nil then ;
end;
function TPasParser.TokenIsProcedureTypeModifier(Parent: TPasElement; function TPasParser.TokenIsProcedureTypeModifier(Parent: TPasElement;
const S: String; out PTM: TProcTypeModifier): Boolean; const S: String; out PTM: TProcTypeModifier): Boolean;
begin begin
@ -1291,6 +1309,17 @@ begin
ExpectToken(tkSemiColon); ExpectToken(tkSemiColon);
end; end;
function TPasParser.IsAnonymousProcAllowed(El: TPasElement): boolean;
begin
while El is TPasExpr do
El:=El.Parent;
if not (El is TPasImplBlock) then
exit(false); // only in statements
while El is TPasImplBlock do
El:=El.Parent;
Result:=El is TProcedureBody; // needs a parent procedure
end;
function TPasParser.CheckPackMode: TPackMode; function TPasParser.CheckPackMode: TPackMode;
begin begin
@ -2007,6 +2036,7 @@ begin
begin begin
repeat repeat
Expr:=DoParseExpression(Params); Expr:=DoParseExpression(Params);
writeln('AAA1 TPasParser.ParseParams ',CurTokenString,' ',curtoken);
if not Assigned(Expr) then if not Assigned(Expr) then
ParseExcSyntaxError; ParseExcSyntaxError;
Params.AddParam(Expr); Params.AddParam(Expr);
@ -2081,7 +2111,7 @@ begin
end; end;
end; end;
function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr; function TPasParser.ParseExprOperand(AParent: TPasElement): TPasExpr;
Function IsWriteOrStr(P : TPasExpr) : boolean; Function IsWriteOrStr(P : TPasExpr) : boolean;
@ -2109,7 +2139,7 @@ function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr;
begin // self.Write(EscapeText(AText)); begin // self.Write(EscapeText(AText));
optk:=CurToken; optk:=CurToken;
NextToken; NextToken;
b:=CreateBinaryExpr(AParent,Last, ParseExpIdent(AParent), TokenToExprOp(optk)); b:=CreateBinaryExpr(AParent,Last, ParseExprOperand(AParent), TokenToExprOp(optk));
if not Assigned(b.right) then if not Assigned(b.right) then
begin begin
b.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; b.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
@ -2180,15 +2210,16 @@ var
ISE: TInlineSpecializeExpr; ISE: TInlineSpecializeExpr;
ST: TPasSpecializeType; ST: TPasSpecializeType;
SrcPos, ScrPos: TPasSourcePos; SrcPos, ScrPos: TPasSourcePos;
ProcType: TProcType;
begin begin
Result:=nil; Result:=nil;
CanSpecialize:=false; CanSpecialize:=false;
aName:=''; aName:='';
case CurToken of case CurToken of
tkString: Last:=CreatePrimitiveExpr(AParent,pekString,CurTokenString); tkString: Last:=CreatePrimitiveExpr(AParent,pekString,CurTokenString);
tkChar: Last:=CreatePrimitiveExpr(AParent,pekString,CurTokenText); tkChar: Last:=CreatePrimitiveExpr(AParent,pekString,CurTokenText);
tkNumber: Last:=CreatePrimitiveExpr(AParent,pekNumber,CurTokenString); tkNumber: Last:=CreatePrimitiveExpr(AParent,pekNumber,CurTokenString);
tkIdentifier: tkIdentifier:
begin begin
CanSpecialize:=true; CanSpecialize:=true;
@ -2212,7 +2243,7 @@ begin
if (CurToken=tkIdentifier) then if (CurToken=tkIdentifier) then
begin begin
SrcPos:=CurTokenPos; SrcPos:=CurTokenPos;
Bin:=CreateBinaryExpr(AParent,Last,ParseExpIdent(AParent),eopNone,SrcPos); Bin:=CreateBinaryExpr(AParent,Last,ParseExprOperand(AParent),eopNone,SrcPos);
if not Assigned(Bin.right) then if not Assigned(Bin.right) then
begin begin
Bin.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; Bin.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
@ -2230,6 +2261,27 @@ begin
Last:=CreateSelfExpr(AParent); Last:=CreateSelfExpr(AParent);
HandleSelf(Last); HandleSelf(Last);
end; end;
tkprocedure,tkfunction:
begin
if CurToken=tkprocedure then
ProcType:=ptAnonymousProcedure
else
ProcType:=ptAnonymousFunction;
if not IsAnonymousProcAllowed(AParent) then
ParseExcExpectedIdentifier;
ok:=false;
try
Result:=TProcedureExpr(CreateElement(TProcedureExpr,'',AParent,visPublic));
TProcedureExpr(Result).Proc:=TPasAnonymousProcedure(ParseProcedureOrFunctionDecl(Result,ProcType));
if CurToken=tkSemicolon then
NextToken; // skip optional semicolon
ok:=true;
finally
if not ok then
Result.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
end;
exit; // do not allow postfix operators . ^. [] ()
end;
tkCaret: tkCaret:
begin begin
// is this still needed? // is this still needed?
@ -2329,6 +2381,11 @@ begin
end; end;
end; end;
function TPasParser.ParseExpIdent(AParent: TPasElement): TPasExpr;
begin
Result:=ParseExprOperand(AParent);
end;
function TPasParser.OpLevel(t: TToken): Integer; function TPasParser.OpLevel(t: TToken): Integer;
begin begin
case t of case t of
@ -2491,12 +2548,12 @@ begin
if (CurToken=tkDot) then if (CurToken=tkDot) then
begin begin
NextToken; NextToken;
x:=CreateBinaryExpr(AParent,x, ParseExpIdent(AParent), TokenToExprOp(tkDot)); x:=CreateBinaryExpr(AParent,x, ParseExprOperand(AParent), TokenToExprOp(tkDot));
end; end;
end end
else else
begin begin
x:=ParseExpIdent(AParent); x:=ParseExprOperand(AParent);
if not Assigned(x) then if not Assigned(x) then
ParseExcSyntaxError; ParseExcSyntaxError;
end; end;
@ -4584,12 +4641,11 @@ end;
function TPasParser.CheckProcedureArgs(Parent: TPasElement; Args: TFPList; function TPasParser.CheckProcedureArgs(Parent: TPasElement; Args: TFPList;
Mandatory: Boolean): boolean; ProcType: TProcType): boolean;
begin begin
NextToken; NextToken;
case CurToken of if CurToken=tkBraceOpen then
tkBraceOpen:
begin begin
Result:=true; Result:=true;
NextToken; NextToken;
@ -4598,18 +4654,34 @@ begin
UngetToken; UngetToken;
ParseArgList(Parent, Args, tkBraceClose); ParseArgList(Parent, Args, tkBraceClose);
end; end;
end;
tkSemicolon,tkColon,tkof,tkis,tkIdentifier:
begin
Result:=false;
if Mandatory then
ParseExc(nParserExpectedLBracketColon,SParserExpectedLBracketColon)
else
UngetToken;
end end
else else
ParseExcTokenError(';'); begin
end; Result:=false;
case ProcType of
ptOperator,ptClassOperator:
ParseExc(nParserExpectedLBracketColon,SParserExpectedLBracketColon);
ptAnonymousProcedure,ptAnonymousFunction:
case CurToken of
tkIdentifier, // e.g. procedure assembler
tkbegin,tkvar,tkconst,tktype,tkprocedure,tkfunction:
UngetToken;
else
ParseExcTokenError('begin');
end;
else
case CurToken of
tkSemicolon, // e.g. procedure;
tkColon, // e.g. function: id
tkof, // e.g. procedure of object
tkis, // e.g. procedure is nested
tkIdentifier: // e.g. procedure cdecl;
UngetToken;
else
ParseExcTokenError(';');
end;
end;
end;
end; end;
procedure TPasParser.HandleProcedureModifier(Parent: TPasElement; pm: TProcedureModifier); procedure TPasParser.HandleProcedureModifier(Parent: TPasElement; pm: TProcedureModifier);
@ -4800,20 +4872,22 @@ Var
Tok : String; Tok : String;
CC : TCallingConvention; CC : TCallingConvention;
PM : TProcedureModifier; PM : TProcedureModifier;
Done: Boolean;
ResultEl: TPasResultElement; ResultEl: TPasResultElement;
OK,IsProc : Boolean; OK: Boolean;
IsProc: Boolean; // true = procedure, false = procedure type
IsAnonymProc: Boolean;
PTM: TProcTypeModifier; PTM: TProcTypeModifier;
ModCount: Integer; ModTokenCount: Integer;
LastToken: TToken; LastToken: TToken;
begin begin
// Element must be non-nil. Removed all checks for not-nil. // Element must be non-nil. Removed all checks for not-nil.
// If it is nil, the following fails anyway. // If it is nil, the following fails anyway.
CheckProcedureArgs(Element,Element.Args,ProcType in [ptOperator,ptClassOperator]); CheckProcedureArgs(Element,Element.Args,ProcType);
IsProc:=Parent is TPasProcedure; IsProc:=Parent is TPasProcedure;
IsAnonymProc:=IsProc and (ProcType in [ptAnonymousProcedure,ptAnonymousFunction]);
case ProcType of case ProcType of
ptFunction,ptClassFunction: ptFunction,ptClassFunction,ptAnonymousFunction:
begin begin
NextToken; NextToken;
if CurToken = tkColon then if CurToken = tkColon then
@ -4882,13 +4956,13 @@ begin
else else
UnGetToken; UnGetToken;
end; end;
ModCount:=0; ModTokenCount:=0;
Repeat Repeat
inc(ModCount); inc(ModTokenCount);
// Writeln(modcount, curtokentext); // Writeln(ModTokenCount, curtokentext);
LastToken:=CurToken; LastToken:=CurToken;
NextToken; NextToken;
if (ModCount<=3) and (CurToken = tkEqual) and not (Parent is TPasProcedure) then if (CurToken = tkEqual) and not IsProc and (ModTokenCount<=3) then
begin begin
// for example: const p: procedure = nil; // for example: const p: procedure = nil;
UngetToken; UngetToken;
@ -4899,6 +4973,7 @@ begin
begin begin
if LastToken=tkSemicolon then if LastToken=tkSemicolon then
ParseExcSyntaxError; ParseExcSyntaxError;
continue;
end end
else if TokenIsCallingConvention(CurTokenString,cc) then else if TokenIsCallingConvention(CurTokenString,cc) then
begin begin
@ -4917,11 +4992,18 @@ begin
NextToken; // remove offset NextToken; // remove offset
end; end;
end; end;
ExpectTokens([tkSemicolon,tkEqual]); if IsProc then
if CurToken=tkEqual then ExpectTokens([tkSemicolon])
UngetToken; else
begin
ExpectTokens([tkSemicolon,tkEqual]);
if CurToken=tkEqual then
UngetToken;
end;
end end
else if IsProc and TokenIsProcedureModifier(Parent,CurTokenString,PM) then else if IsAnonymProc and TokenIsAnonymousProcedureModifier(Parent,CurTokenString,PM) then
HandleProcedureModifier(Parent,PM)
else if IsProc and not IsAnonymProc and TokenIsProcedureModifier(Parent,CurTokenString,PM) then
HandleProcedureModifier(Parent,PM) HandleProcedureModifier(Parent,PM)
else if TokenIsProcedureTypeModifier(Parent,CurTokenString,PTM) then else if TokenIsProcedureTypeModifier(Parent,CurTokenString,PTM) then
HandleProcedureTypeModifier(Element,PTM) HandleProcedureTypeModifier(Element,PTM)
@ -4930,16 +5012,22 @@ begin
Tok:=UpperCase(CurTokenString); Tok:=UpperCase(CurTokenString);
NextToken; NextToken;
If (tok<>'NAME') then If (tok<>'NAME') then
Element.Hints:=Element.Hints+[hLibrary] begin
if hLibrary in Element.Hints then
ParseExcSyntaxError;
Element.Hints:=Element.Hints+[hLibrary];
end
else else
begin begin
NextToken; // Should be export name string. NextToken; // Should be "export name astring".
ExpectToken(tkSemicolon); ExpectToken(tkSemicolon);
end; end;
end end
else if DoCheckHint(Element) then else if (not IsAnonymProc) and DoCheckHint(Element) then
// deprecated,platform,experimental,library, unimplemented etc
ConsumeSemi ConsumeSemi
else if (CurToken=tkIdentifier) and (CompareText(CurTokenText,'alias')=0) then else if (CurToken=tkIdentifier) and (not IsAnonymProc)
and (CompareText(CurTokenText,'alias')=0) then
begin begin
ExpectToken(tkColon); ExpectToken(tkColon);
ExpectToken(tkString); ExpectToken(tkString);
@ -4959,44 +5047,48 @@ begin
begin begin
// ToDo: read FPC's [] modifiers, e.g. [public,alias:''] // ToDo: read FPC's [] modifiers, e.g. [public,alias:'']
repeat repeat
NextToken NextToken;
if CurToken in [tkSquaredBraceOpen,tkSemicolon] then
CheckToken(tkSquaredBraceClose);
until CurToken = tkSquaredBraceClose; until CurToken = tkSquaredBraceClose;
ExpectToken(tkSemicolon); ExpectToken(tkSemicolon);
end; end;
end end
else else
CheckToken(tkSemicolon);
Done:=(CurToken=tkSemiColon);
if Done then
begin begin
NextToken; // not a modifier/hint/calling convention
Done:=Not ((Curtoken=tkSquaredBraceOpen) or if LastToken=tkSemicolon then
TokenIsProcedureModifier(Parent,CurtokenString,PM) or begin
TokenIsProcedureTypeModifier(Parent,CurtokenString,PTM) or UngetToken;
IsCurTokenHint() or if IsAnonymProc and (ModTokenCount<=1) then
TokenIsCallingConvention(CurTokenString,cc) or ParseExcSyntaxError;
(CurToken=tkIdentifier) and (CompareText(CurTokenText,'alias')=0)); break;
{$ifdef VerbosePasParser} end
DumpCurToken('Done '+IntToStr(Ord(Done))); else if IsAnonymProc then
{$endif} begin
UngetToken; UngetToken;
break;
end
else
begin
CheckToken(tkSemicolon);
continue;
end;
end; end;
// Writeln('Done: ',TokenInfos[Curtoken],' ',CurtokenString);
// Writeln('Done: ',TokenInfos[Curtoken],' ',CurtokenString); Until false;
Until Done;
if DoCheckHint(Element) then // deprecated,platform,experimental,library, unimplemented etc
ConsumeSemi;
if (ProcType in [ptOperator,ptClassOperator]) and (Parent is TPasOperator) then if (ProcType in [ptOperator,ptClassOperator]) and (Parent is TPasOperator) then
TPasOperator(Parent).CorrectName; TPasOperator(Parent).CorrectName;
Engine.FinishScope(stProcedureHeader,Element); Engine.FinishScope(stProcedureHeader,Element);
if (Parent is TPasProcedure) if IsProc
and (not TPasProcedure(Parent).IsForward) and (not TPasProcedure(Parent).IsForward)
and (not TPasProcedure(Parent).IsExternal) and (not TPasProcedure(Parent).IsExternal)
and ((Parent.Parent is TImplementationSection) and ((Parent.Parent is TImplementationSection)
or (Parent.Parent is TProcedureBody)) or (Parent.Parent is TProcedureBody)
or IsAnonymProc)
then then
ParseProcedureBody(Parent); ParseProcedureBody(Parent);
if Parent is TPasProcedure then if IsProc then
Engine.FinishScope(stProcedure,Parent); Engine.FinishScope(stProcedure,Parent);
end; end;
@ -5257,6 +5349,7 @@ procedure TPasParser.ParseProcBeginBlock(Parent: TProcedureBody);
var var
BeginBlock: TPasImplBeginBlock; BeginBlock: TPasImplBeginBlock;
SubBlock: TPasImplElement; SubBlock: TPasImplElement;
Proc: TPasProcedure;
begin begin
BeginBlock := TPasImplBeginBlock(CreateElement(TPasImplBeginBlock, '', Parent)); BeginBlock := TPasImplBeginBlock(CreateElement(TPasImplBeginBlock, '', Parent));
Parent.Body := BeginBlock; Parent.Body := BeginBlock;
@ -5273,7 +5366,11 @@ begin
ExpectToken(tkend); ExpectToken(tkend);
end; end;
until false; until false;
ExpectToken(tkSemicolon); Proc:=Parent.Parent as TPasProcedure;
if Proc.GetProcTypeEnum in [ptAnonymousProcedure,ptAnonymousFunction] then
NextToken
else
ExpectToken(tkSemicolon);
// writeln('TPasParser.ParseProcBeginBlock ended ',curtokenstring); // writeln('TPasParser.ParseProcBeginBlock ended ',curtokenstring);
end; end;
@ -5974,12 +6071,15 @@ begin
ptDestructor : Result:=TPasDestructor; ptDestructor : Result:=TPasDestructor;
ptOperator : Result:=TPasOperator; ptOperator : Result:=TPasOperator;
ptClassOperator : Result:=TPasClassOperator; ptClassOperator : Result:=TPasClassOperator;
ptAnonymousProcedure: Result:=TPasAnonymousProcedure;
ptAnonymousFunction: Result:=TPasAnonymousFunction;
else else
ParseExc(nParserUnknownProcedureType,SParserUnknownProcedureType,[Ord(ProcType)]); ParseExc(nParserUnknownProcedureType,SParserUnknownProcedureType,[Ord(ProcType)]);
end; end;
end; end;
function TPasParser.ParseProcedureOrFunctionDecl(Parent: TPasElement; ProcType: TProcType;AVisibility : TPasMemberVisibility = VisDefault): TPasProcedure; function TPasParser.ParseProcedureOrFunctionDecl(Parent: TPasElement;
ProcType: TProcType; AVisibility: TPasMemberVisibility): TPasProcedure;
function ExpectProcName: string; function ExpectProcName: string;
@ -6023,9 +6123,8 @@ var
IsTokenBased , ok: Boolean; IsTokenBased , ok: Boolean;
begin begin
If (Not (ProcType in [ptOperator,ptClassOperator])) then case ProcType of
Name:=ExpectProcName ptOperator,ptClassOperator:
else
begin begin
NextToken; NextToken;
IsTokenBased:=Curtoken<>tkIdentifier; IsTokenBased:=Curtoken<>tkIdentifier;
@ -6037,14 +6136,19 @@ begin
ParseExc(nErrUnknownOperatorType,SErrUnknownOperatorType,[CurTokenString]); ParseExc(nErrUnknownOperatorType,SErrUnknownOperatorType,[CurTokenString]);
Name:=OperatorNames[Ot]; Name:=OperatorNames[Ot];
end; end;
ptAnonymousProcedure,ptAnonymousFunction:
Name:='';
else
Name:=ExpectProcName;
end;
PC:=GetProcedureClass(ProcType); PC:=GetProcedureClass(ProcType);
Parent:=CheckIfOverLoaded(Parent,Name); if Name<>'' then
Parent:=CheckIfOverLoaded(Parent,Name);
Result:=TPasProcedure(CreateElement(PC,Name,Parent,AVisibility)); Result:=TPasProcedure(CreateElement(PC,Name,Parent,AVisibility));
ok:=false; ok:=false;
try try
if Not (ProcType in [ptFunction, ptClassFunction, ptOperator, ptClassOperator]) then case ProcType of
Result.ProcType := TPasProcedureType(CreateElement(TPasProcedureType, '', Result)) ptFunction, ptClassFunction, ptOperator, ptClassOperator, ptAnonymousFunction:
else
begin begin
Result.ProcType := CreateFunctionType('', 'Result', Result, False, CurTokenPos); Result.ProcType := CreateFunctionType('', 'Result', Result, False, CurTokenPos);
if (ProcType in [ptOperator, ptClassOperator]) then if (ProcType in [ptOperator, ptClassOperator]) then
@ -6054,6 +6158,9 @@ begin
TPasOperator(Result).CorrectName; TPasOperator(Result).CorrectName;
end; end;
end; end;
else
Result.ProcType := TPasProcedureType(CreateElement(TPasProcedureType, '', Result));
end;
ParseProcedureOrFunctionHeader(Result, Result.ProcType, ProcType, False); ParseProcedureOrFunctionHeader(Result, Result.ProcType, ProcType, False);
Result.Hints:=Result.ProcType.Hints; Result.Hints:=Result.ProcType.Hints;
Result.HintMessage:=Result.ProcType.HintMessage; Result.HintMessage:=Result.ProcType.HintMessage;

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

@ -32,7 +32,7 @@ type
TSrcMarker = record TSrcMarker = record
Kind: TSrcMarkerKind; Kind: TSrcMarkerKind;
Filename: string; Filename: string;
Row: integer; Row: cardinal;
StartCol, EndCol: integer; // token start, end column StartCol, EndCol: integer; // token start, end column
Identifier: string; Identifier: string;
Next: PSrcMarker; Next: PSrcMarker;
@ -447,6 +447,25 @@ type
Procedure TestProc_ImplicitCalls; Procedure TestProc_ImplicitCalls;
Procedure TestProc_Absolute; Procedure TestProc_Absolute;
// anonymous procs
// ToDo: fppas2js: check "is TPasFunction", ".FuncType", "parent is TPasProcedureBody"
Procedure TestAnonymousProc_Assign;
// ToDo: does Delphi allow/require semicolon in assign?
Procedure TestAnonymousProc_Arg;
// ToDo: does Delphi allow/require semicolon in arg?
// ToDo: does Delphi allow calling directly?: function(i: word):word begin end(3)
Procedure TestAnonymousProc_EqualFail;
// ToDo: does Delphi allow ano proc in const?
Procedure TestAnonymousProc_ConstFail;
// ToDo: does Delphi allow assembler or calling conventions?
Procedure TestAnonymousProc_Assembler;
Procedure TestAnonymousProc_NameFail;
Procedure TestAnonymousProc_StatementFail;
Procedure TestAnonymousProc_Typecast;// ToDo
// ToDo: ano in with
// ToDo: ano in nested
// ToDo: ano in ano
// record // record
Procedure TestRecord; Procedure TestRecord;
Procedure TestRecordVariant; Procedure TestRecordVariant;
@ -1411,7 +1430,7 @@ var
DeclEl:=TPasAliasType(El).DestType; DeclEl:=TPasAliasType(El).DestType;
ResolverEngine.UnmangleSourceLineNumber(DeclEl.SourceLinenumber,LabelLine,LabelCol); ResolverEngine.UnmangleSourceLineNumber(DeclEl.SourceLinenumber,LabelLine,LabelCol);
if (aLabel^.Filename=DeclEl.SourceFilename) if (aLabel^.Filename=DeclEl.SourceFilename)
and (aLabel^.Row=LabelLine) and (integer(aLabel^.Row)=LabelLine)
and (aLabel^.StartCol<=LabelCol) and (aLabel^.StartCol<=LabelCol)
and (aLabel^.EndCol>=LabelCol) then and (aLabel^.EndCol>=LabelCol) then
exit; // success exit; // success
@ -1491,8 +1510,8 @@ begin
if (Marker<>nil) then if (Marker<>nil) then
begin begin
if Item.SourcePos.Row<>Marker^.Row then continue; if Item.SourcePos.Row<>Marker^.Row then continue;
if (Item.SourcePos.Column<Marker^.StartCol) if (integer(Item.SourcePos.Column)<Marker^.StartCol)
or (Item.SourcePos.Column>Marker^.EndCol) then continue; or (integer(Item.SourcePos.Column)>Marker^.EndCol) then continue;
end; end;
// found // found
FResolverGoodMsgs.Add(Item); FResolverGoodMsgs.Add(Item);
@ -7135,6 +7154,137 @@ begin
'begin']); 'begin']);
end; end;
procedure TTestResolver.TestAnonymousProc_Assign;
begin
StartProgram(false);
Add([
'type',
' TFunc = reference to function(x: word): word;',
'var Func: TFunc;',
'procedure DoIt(a: word);',
'begin',
' Func:=function(b:word): word',
' begin',
' Result:=a+b;',
' exit(b);',
' exit(Result);',
' end;',
' a:=3;',// test semicolon
'end;',
'begin']);
ParseProgram;
end;
procedure TTestResolver.TestAnonymousProc_Arg;
begin
StartProgram(false);
Add([
'type',
' TProc = reference to procedure;',
' TFunc = reference to function(x: word): word;',
'procedure DoMore(f,g: TProc);',
'begin',
'end;',
'procedure DoIt(f: TFunc);',
'begin',
' DoIt(function(b:word): word',
' begin',
' Result:=1+b;',
' end;);',
' DoMore(procedure begin end;, procedure begin end);',
'end;',
'begin']);
ParseProgram;
end;
procedure TTestResolver.TestAnonymousProc_EqualFail;
begin
StartProgram(false);
Add([
'type',
' TFunc = reference to function(x: word): word;',
'procedure DoIt(f: TFunc);',
'var w: word;',
'begin',
' if w=function(b:word): word',
' begin',
' Result:=1+b;',
' end; then ;',
'end;',
'begin']);
CheckResolverException('Incompatible types: got "Procedure/Function" expected "Word"',nIncompatibleTypesGotExpected);
end;
procedure TTestResolver.TestAnonymousProc_ConstFail;
begin
StartProgram(false);
Add([
'type',
' TProc = reference to procedure;',
'const',
' p: TProc = procedure begin end;',
'begin']);
CheckParserException('Identifier expected at token "procedure" in file afile.pp at line 5 column 14',nParserExpectedIdentifier);
end;
procedure TTestResolver.TestAnonymousProc_Assembler;
begin
StartProgram(false);
Add([
'type',
' TProc = reference to procedure;',
'procedure DoIt(p: TProc);',
'begin',
' p:=procedure assembler; asm end;',
' p:=procedure() assembler; asm end;',
'end;',
'begin']);
ParseProgram;
end;
procedure TTestResolver.TestAnonymousProc_NameFail;
begin
StartProgram(false);
Add([
'type',
' TProc = reference to procedure;',
'procedure DoIt(p: TProc);',
'begin',
' p:=procedure Bla() begin end;',
'end;',
'begin']);
CheckParserException(SParserSyntaxError,nParserSyntaxError);
end;
procedure TTestResolver.TestAnonymousProc_StatementFail;
begin
StartProgram(false);
Add([
'procedure DoIt;',
'begin',
' procedure () begin end;',
'end;',
'begin']);
CheckParserException(SParserSyntaxError,nParserSyntaxError);
end;
procedure TTestResolver.TestAnonymousProc_Typecast;
begin
exit;
StartProgram(false);
Add([
'type',
' TProc = reference to procedure(w: word);',
'procedure DoIt(p: TProc);',
'begin',
' p:=TProc(procedure(b: byte) begin end);',
' p:=TProc(procedure(b: byte) begin end;);',
'end;',
'begin']);
ParseProgram;
end;
procedure TTestResolver.TestRecord; procedure TTestResolver.TestRecord;
begin begin
StartProgram(false); StartProgram(false);