fcl-passrc: anonymous functions: with-block

git-svn-id: trunk@40518 -
This commit is contained in:
Mattias Gaertner 2018-12-10 18:07:18 +00:00
parent 7815ed4de1
commit b0d7ba7e6f
6 changed files with 293 additions and 97 deletions

View File

@ -818,7 +818,7 @@ type
{ TPasInitialFinalizationScope - e.g. TInitializationSection, TFinalizationSection }
TPasInitialFinalizationScope = Class(TPasIdentifierScope)
TPasInitialFinalizationScope = Class(TPasScope)
public
References: TPasScopeReferences; // created by TPasAnalyzer, not used by resolver
function AddReference(El: TPasElement; Access: TPSRefAccess): TPasScopeReference;
@ -1358,6 +1358,7 @@ type
procedure AddArgument(El: TPasArgument); virtual;
procedure AddFunctionResult(El: TPasResultElement); virtual;
procedure AddExceptOn(El: TPasImplExceptOn); virtual;
procedure AddWithDo(El: TPasImplWithDo); virtual;
procedure ResolveImplBlock(Block: TPasImplBlock); virtual;
procedure ResolveImplElement(El: TPasImplElement); virtual;
procedure ResolveImplCaseOf(CaseOf: TPasImplCaseOf); virtual;
@ -1416,6 +1417,7 @@ type
procedure FinishMethodImplHeader(ImplProc: TPasProcedure); virtual;
procedure FinishExceptOnExpr; virtual;
procedure FinishExceptOnStatement; virtual;
procedure FinishWithDo(El: TPasImplWithDo); virtual;
procedure FinishDeclaration(El: TPasElement); virtual;
procedure FinishVariable(El: TPasVariable); virtual;
procedure FinishPropertyOfClass(PropEl: TPasProperty); virtual;
@ -1654,6 +1656,7 @@ type
procedure CheckFoundElement(const FindData: TPRFindData;
Ref: TResolvedReference); virtual;
function GetVisibilityContext: TPasElement;
procedure BeginScope(ScopeType: TPasScopeType; El: TPasElement); override;
procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); override;
procedure FinishTypeAlias(var NewType: TPasType); override;
function IsUnitIntfFinished(AModule: TPasModule): boolean;
@ -1690,12 +1693,14 @@ type
// scopes
function CreateScope(El: TPasElement; ScopeClass: TPasScopeClass): TPasScope; virtual;
procedure PopScope;
procedure PopWithScope(El: TPasImplWithDo);
procedure PushScope(Scope: TPasScope); overload;
function PushScope(El: TPasElement; ScopeClass: TPasScopeClass): TPasScope; overload;
function PushModuleDotScope(aModule: TPasModule): TPasModuleDotScope;
function PushClassDotScope(var CurClassType: TPasClassType): TPasDotClassScope;
function PushRecordDotScope(CurRecordType: TPasRecordType): TPasDotRecordScope;
function PushEnumDotScope(CurEnumType: TPasEnumType): TPasDotEnumTypeScope;
function PushWithExprScope(Expr: TPasExpr): TPasWithExprScope;
procedure ResetSubScopes(out Depth: integer);
procedure RestoreSubScopes(Depth: integer);
function GetInheritedExprScope(ErrorEl: TPasElement): TPasProcedureScope;
@ -5756,6 +5761,11 @@ begin
PopScope;
end;
procedure TPasResolver.FinishWithDo(El: TPasImplWithDo);
begin
PopWithScope(El);
end;
procedure TPasResolver.FinishDeclaration(El: TPasElement);
var
C: TClass;
@ -7560,86 +7570,25 @@ begin
end;
procedure TPasResolver.ResolveImplWithDo(El: TPasImplWithDo);
// Note: the expressions were already resolved during parsing
// and the scopes were already stored in a TPasWithScope.
// -> simply push them onto the scope stack
var
i, OldScopeCount: Integer;
Expr, ErrorEl: TPasExpr;
ExprResolved: TPasResolverResult;
TypeEl: TPasType;
i: Integer;
WithScope: TPasWithScope;
WithExprScope: TPasWithExprScope;
ExprScope: TPasScope;
OnlyTypeMembers, IsClassOf: Boolean;
ClassEl: TPasClassType;
ExprScope: TPasWithExprScope;
begin
OldScopeCount:=ScopeCount;
WithScope:=TPasWithScope(CreateScope(El,TPasWithScope));
if not (El.CustomData is TPasWithScope) then
RaiseInternalError(20181210175349);
WithScope:=TPasWithScope(El.CustomData);
PushScope(WithScope);
for i:=0 to El.Expressions.Count-1 do
for i:=0 to WithScope.ExpressionScopes.Count-1 do
begin
Expr:=TPasExpr(El.Expressions[i]);
ResolveExpr(Expr,rraRead);
ComputeElement(Expr,ExprResolved,[rcSetReferenceFlags]);
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveImplWithDo ExprResolved=',GetResolverResultDbg(ExprResolved));
{$ENDIF}
ErrorEl:=Expr;
TypeEl:=ExprResolved.LoTypeEl;
// ToDo: use last element in Expr for error position
if TypeEl=nil then
RaiseMsg(20170216152004,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot,
[BaseTypeNames[ExprResolved.BaseType]],ErrorEl);
OnlyTypeMembers:=false;
IsClassOf:=false;
if TypeEl.ClassType=TPasRecordType then
begin
ExprScope:=NoNil(TPasRecordType(TypeEl).CustomData) as TPasRecordScope;
if ExprResolved.IdentEl is TPasType then
// e.g. with TPoint do PointInCircle
OnlyTypeMembers:=true;
end
else if TypeEl.ClassType=TPasClassType then
begin
ExprScope:=NoNil(TPasClassType(TypeEl).CustomData) as TPasClassScope;
if ExprResolved.IdentEl is TPasType then
// e.g. with TFPMemoryImage do FindHandlerFromExtension()
OnlyTypeMembers:=true;
end
else if TypeEl.ClassType=TPasClassOfType then
begin
// e.g. with ImageClass do FindHandlerFromExtension()
ClassEl:=ResolveAliasType(TPasClassOfType(TypeEl).DestType) as TPasClassType;
ExprScope:=ClassEl.CustomData as TPasClassScope;
OnlyTypeMembers:=true;
IsClassOf:=true;
end
else
RaiseMsg(20170216152007,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot,
[GetElementTypeName(TypeEl)],ErrorEl);
WithExprScope:=ScopeClass_WithExpr.Create;
WithExprScope.WithScope:=WithScope;
WithExprScope.Index:=i;
WithExprScope.Expr:=Expr;
WithExprScope.Scope:=ExprScope;
if not (ExprResolved.IdentEl is TPasType) then
Include(WithExprScope.Flags,wesfNeedTmpVar);
if OnlyTypeMembers then
Include(WithExprScope.Flags,wesfOnlyTypeMembers);
if IsClassOf then
Include(WithExprScope.Flags,wesfIsClassOf);
if (not (rrfWritable in ExprResolved.Flags))
and (ExprResolved.BaseType=btContext)
and (ExprResolved.LoTypeEl.ClassType=TPasRecordType) then
Include(WithExprScope.Flags,wesfConstParent);
WithScope.ExpressionScopes.Add(WithExprScope);
PushScope(WithExprScope);
ExprScope:=TPasWithExprScope(WithScope.ExpressionScopes[i]);
PushScope(ExprScope);
end;
ResolveImplElement(El.Body);
CheckTopScope(ScopeClass_WithExpr);
if TopScope<>WithScope.ExpressionScopes[WithScope.ExpressionScopes.Count-1] then
RaiseInternalError(20160923102846);
while ScopeCount>OldScopeCount do
PopScope;
PopWithScope(El);
end;
procedure TPasResolver.ResolveImplAsm(El: TPasImplAsmStatement);
@ -7854,6 +7803,7 @@ begin
ResolveRecordValues(TRecordValues(El));
end
else if ElClass=TProcedureExpr then
// resolved by FinishScope(stProcedure)
else
RaiseNotYetImplemented(20170222184329,El);
@ -9372,14 +9322,34 @@ var
CurEl: TPasElement;
Identifier: TPasIdentifier;
CurClassScope: TPasClassScope;
C: TClass;
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.AddProcedure ',GetObjName(El));
{$ENDIF}
if not (TopScope is TPasIdentifierScope) then
RaiseInvalidScopeForElement(20160922163522,El);
// Note: El.ProcType is nil ! It is parsed later.
ProcName:=El.Name;
if El.Name<>'' then
begin
// named proc
if not (TopScope is TPasIdentifierScope) then
RaiseInvalidScopeForElement(20160922163522,El);
end
else
begin
// anonymous proc
C:=TopScope.ClassType;
if (C=ScopeClass_InitialFinalization)
or C.InheritsFrom(TPasProcedureScope)
or (C=TPasWithScope)
or (C=ScopeClass_WithExpr)
or (C=TPasExceptOnScope)
or (C=TPasForLoopScope) then
// ok
else
RaiseInvalidScopeForElement(20181210173134,El);
end;
// Note: El.ProcType is nil ! It is parsed later.
HasDot:=Pos('.',ProcName)>1;
if (not HasDot) and (ProcName<>'') then
AddIdentifier(TPasIdentifierScope(TopScope),ProcName,El,pikProc);
@ -9511,6 +9481,16 @@ begin
PushScope(El,TPasExceptOnScope);
end;
procedure TPasResolver.AddWithDo(El: TPasImplWithDo);
var
WithScope: TPasWithScope;
begin
if TPasWithScope.FreeOnPop then
RaiseInternalError(20181210162344);
WithScope:=TPasWithScope(CreateScope(El,TPasWithScope));
PushScope(WithScope);
end;
procedure TPasResolver.AddProcedureBody(El: TProcedureBody);
begin
if El=nil then ;
@ -14166,6 +14146,8 @@ begin
else if AClass=TPasMethodResolution then
else if AClass=TPasImplExceptOn then
AddExceptOn(TPasImplExceptOn(El))
else if AClass=TPasImplWithDo then
AddWithDo(TPasImplWithDo(El))
else if AClass=TPasImplLabelMark then
else if AClass=TPasOverloadedProc then
else if (AClass=TInterfaceSection)
@ -14759,6 +14741,15 @@ begin
Result:=nil;
end;
procedure TPasResolver.BeginScope(ScopeType: TPasScopeType; El: TPasElement);
begin
case ScopeType of
stWithExpr: PushWithExprScope(El as TPasExpr);
else
RaiseMsg(20181210163324,nNotYetImplemented,sNotYetImplemented+' BeginScope',[IntToStr(ord(ScopeType))],nil);
end;
end;
procedure TPasResolver.FinishScope(ScopeType: TPasScopeType; El: TPasElement);
begin
if IsElementSkipped(El) then exit;
@ -14772,6 +14763,7 @@ begin
stProcedureHeader: FinishProcedureType(El as TPasProcedureType);
stExceptOnExpr: FinishExceptOnExpr;
stExceptOnStatement: FinishExceptOnStatement;
stWithExpr: FinishWithDo(El as TPasImplWithDo);
stDeclaration: FinishDeclaration(El);
stAncestors: FinishAncestors(El as TPasClassType);
stInitialFinalization: FinishInitialFinalization(El as TPasImplBlock);
@ -15355,6 +15347,23 @@ begin
FTopScope:=nil;
end;
procedure TPasResolver.PopWithScope(El: TPasImplWithDo);
var
WithScope: TPasWithScope;
i: Integer;
begin
WithScope:=El.CustomData as TPasWithScope;
for i:=WithScope.ExpressionScopes.Count-1 downto 0 do
begin
CheckTopScope(ScopeClass_WithExpr);
if TopScope<>WithScope.ExpressionScopes[i] then
RaiseInternalError(20160923102846);
PopScope;
end;
CheckTopScope(TPasWithScope);
PopScope;
end;
procedure TPasResolver.PushScope(Scope: TPasScope);
begin
if Scope=nil then
@ -15454,6 +15463,84 @@ begin
PushScope(Result);
end;
function TPasResolver.PushWithExprScope(Expr: TPasExpr): TPasWithExprScope;
var
WithEl: TPasImplWithDo;
WithScope: TPasWithScope;
ExprResolved: TPasResolverResult;
ErrorEl: TPasExpr;
TypeEl: TPasType;
OnlyTypeMembers, IsClassOf: Boolean;
ExprScope: TPasIdentifierScope;
ClassEl: TPasClassType;
WithExprScope: TPasWithExprScope;
begin
if not (Expr.Parent is TPasImplWithDo) then
RaiseInternalError(20181210163412,GetObjName(Expr.Parent));
WithEl:=TPasImplWithDo(Expr.Parent);
if not (WithEl.CustomData is TPasWithScope) then
RaiseInternalError(20181210175526);
WithScope:=TPasWithScope(WithEl.CustomData);
ResolveExpr(Expr,rraRead);
ComputeElement(Expr,ExprResolved,[rcSetReferenceFlags]);
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.PushWithExprScope ExprResolved=',GetResolverResultDbg(ExprResolved));
{$ENDIF}
ErrorEl:=Expr;
TypeEl:=ExprResolved.LoTypeEl;
// ToDo: use last element in Expr for error position
if TypeEl=nil then
RaiseMsg(20170216152004,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot,
[BaseTypeNames[ExprResolved.BaseType]],ErrorEl);
OnlyTypeMembers:=false;
IsClassOf:=false;
if TypeEl.ClassType=TPasRecordType then
begin
ExprScope:=NoNil(TPasRecordType(TypeEl).CustomData) as TPasRecordScope;
if ExprResolved.IdentEl is TPasType then
// e.g. with TPoint do PointInCircle
OnlyTypeMembers:=true;
end
else if TypeEl.ClassType=TPasClassType then
begin
ExprScope:=NoNil(TPasClassType(TypeEl).CustomData) as TPasClassScope;
if ExprResolved.IdentEl is TPasType then
// e.g. with TFPMemoryImage do FindHandlerFromExtension()
OnlyTypeMembers:=true;
end
else if TypeEl.ClassType=TPasClassOfType then
begin
// e.g. with ImageClass do FindHandlerFromExtension()
ClassEl:=ResolveAliasType(TPasClassOfType(TypeEl).DestType) as TPasClassType;
ExprScope:=ClassEl.CustomData as TPasClassScope;
OnlyTypeMembers:=true;
IsClassOf:=true;
end
else
RaiseMsg(20170216152007,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot,
[GetElementTypeName(TypeEl)],ErrorEl);
WithExprScope:=ScopeClass_WithExpr.Create;
WithExprScope.WithScope:=WithScope;
WithExprScope.Index:=WithEl.Expressions.Count;
WithExprScope.Expr:=Expr;
WithExprScope.Scope:=ExprScope;
if not (ExprResolved.IdentEl is TPasType) then
Include(WithExprScope.Flags,wesfNeedTmpVar);
if OnlyTypeMembers then
Include(WithExprScope.Flags,wesfOnlyTypeMembers);
if IsClassOf then
Include(WithExprScope.Flags,wesfIsClassOf);
if (not (rrfWritable in ExprResolved.Flags))
and (ExprResolved.BaseType=btContext)
and (ExprResolved.LoTypeEl.ClassType=TPasRecordType) then
Include(WithExprScope.Flags,wesfConstParent);
WithScope.ExpressionScopes.Add(WithExprScope);
PushScope(WithExprScope);
Result:=WithExprScope;
end;
procedure TPasResolver.ResetSubScopes(out Depth: integer);
// move all sub scopes from Scopes to SubScopes
begin

View File

@ -1552,6 +1552,8 @@ begin
end
else if C=TInheritedExpr then
UseInheritedExpr(TInheritedExpr(El))
else if C=TProcedureExpr then
UseProcedure(TProcedureExpr(El).Proc)
else
RaiseNotSupported(20170307085444,El);
end;

View File

@ -171,6 +171,7 @@ type
stResourceString, // e.g. TPasResString
stProcedure, // also method, procedure, constructor, destructor, ...
stProcedureHeader,
stWithExpr, // calls BeginScope after parsing every WITH-expression
stExceptOnExpr,
stExceptOnStatement,
stDeclaration, // e.g. a TPasProperty, TPasVariable, TPasArgument
@ -212,6 +213,7 @@ type
function CreateFunctionType(const AName, AResultName: String; AParent: TPasElement;
UseParentAsResultParent: Boolean; const ASrcPos: TPasSourcePos): TPasFunctionType;
function FindElement(const AName: String): TPasElement; virtual; abstract;
procedure BeginScope(ScopeType: TPasScopeType; El: TPasElement); virtual;
procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); virtual;
procedure FinishTypeAlias(var aType: TPasType); virtual;
function FindModule(const AName: String): TPasModule; virtual;
@ -809,6 +811,13 @@ begin
visDefault, ASrcPos));
end;
procedure TPasTreeContainer.BeginScope(ScopeType: TPasScopeType; El: TPasElement
);
begin
if ScopeType=stModule then ; // avoid compiler warning
if El=nil then ;
end;
procedure TPasTreeContainer.FinishScope(ScopeType: TPasScopeType;
El: TPasElement);
begin
@ -4660,6 +4669,11 @@ begin
tkIdentifier, // e.g. procedure assembler
tkbegin,tkvar,tkconst,tktype,tkprocedure,tkfunction:
UngetToken;
tkColon:
if ProcType=ptAnonymousFunction then
UngetToken
else
ParseExcTokenError('begin');
else
ParseExcTokenError('begin');
end;
@ -5465,9 +5479,13 @@ var
{$ENDIF}
function CloseBlock: boolean; // true if parent reached
var C: TPasImplBlockClass;
begin
if CurBlock.ClassType=TPasImplExceptOn then
Engine.FinishScope(stExceptOnStatement,CurBlock);
C:=TPasImplBlockClass(CurBlock.ClassType);
if C=TPasImplExceptOn then
Engine.FinishScope(stExceptOnStatement,CurBlock)
else if C=TPasImplWithDo then
Engine.FinishScope(stWithExpr,CurBlock);
CurBlock:=CurBlock.Parent as TPasImplBlock;
Result:=CurBlock=Parent;
end;
@ -5719,11 +5737,12 @@ begin
CheckSemicolon;
SrcPos:=CurTokenPos;
NextToken;
El:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock,SrcPos));
Left:=DoParseExpression(CurBlock);
//writeln(i,'WITH Expr="',Expr,'" Token=',CurTokenText);
El:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock,SrcPos));
TPasImplWithDo(El).AddExpression(Left);
Left.Parent:=El;
Engine.BeginScope(stWithExpr,Left);
Left:=nil;
CreateBlock(TPasImplWithDo(El));
El:=nil;
@ -5735,6 +5754,7 @@ begin
Left:=DoParseExpression(CurBlock);
//writeln(i,'WITH ...,Expr="',Expr,'" Token=',CurTokenText);
TPasImplWithDo(CurBlock).AddExpression(Left);
Engine.BeginScope(stWithExpr,Left);
Left:=nil;
until false;
end;

View File

@ -457,15 +457,12 @@ type
Procedure TestAnonymousProc_Assembler;
Procedure TestAnonymousProc_NameFail;
Procedure TestAnonymousProc_StatementFail;
// ToDo: Delphi does not support calling directly: function(i: word):word begin end(3)
// ToDo: Delphi does support calling with typecast: TFunc(function(i: word):word begin end)(3)
Procedure TestAnonymousProc_Typecast;
Procedure TestAnonymousProc_TypecastToResultFail;
Procedure TestAnonymousProc_With; // ToDo
// ToDo: ano in with (ano proc can access with scope)
// ToDo: ano in except E: Exception do ..
// ToDo: ano in nested
// ToDo: ano in ano
Procedure TestAnonymousProc_With;
Procedure TestAnonymousProc_ExceptOn;
Procedure TestAnonymousProc_Nested;
// analyzer
// ToDo: fppas2js: check "is TPasFunction", ".FuncType", "is TPasProcedureBody"
// record
@ -7318,9 +7315,16 @@ begin
Add([
'type',
' TProc = reference to procedure(w: word);',
' TArr = array of word;',
' TFuncArr = reference to function: TArr;',
'procedure DoIt(p: TProc);',
'var',
' w: word;',
' a: TArr;',
'begin',
' p:=TProc(procedure(b: smallint) begin end);',
' a:=TFuncArr(function: TArr begin end)();',
' w:=TFuncArr(function: TArr begin end)()[3];',
'end;',
'begin']);
ParseProgram;
@ -7342,27 +7346,89 @@ end;
procedure TTestResolver.TestAnonymousProc_With;
begin
exit;
StartProgram(false);
Add([
'type',
' TProc = reference to procedure(w: word);',
' TObject = class end;',
' TBird = class',
' {#b_bool}b: boolean;',
' {#bool}b: boolean;',
' end;',
'procedure DoIt({#i}i: longint);',
'var',
' {#p}p: TProc;',
' {#b_bird}bi: TBird;',
' {#bird}bird: TBird;',
'begin',
' with {@b_bird}bi do begin',
' with {@bird}bird do',
' {@p}p:=procedure({#w}w: word)',
' begin',
' {@b_bool}b:=true;',
// ' {@b_bool}b:=({@w}w+{@i}i)>2;',
' end; end;',
' {@bool}b:=true;',
' {@bool}b:=({@w}w+{@i}i)>2;',
' end;',
'end;',
'begin']);
ParseProgram;
end;
procedure TTestResolver.TestAnonymousProc_ExceptOn;
begin
StartProgram(false);
Add([
'type',
' TProc = reference to procedure;',
' TObject = class end;',
' Exception = class',
' {#bool}b: boolean;',
' end;',
'procedure DoIt;',
'var',
' {#p}p: TProc;',
'begin',
' try',
' except',
' on {#E}E: Exception do',
' {@p}p:=procedure',
' begin',
' {@E}E.{@bool}b:=true;',
' end;',
' end;',
'end;',
'begin']);
ParseProgram;
end;
procedure TTestResolver.TestAnonymousProc_Nested;
begin
StartProgram(false);
Add([
'type',
' TProc = reference to procedure;',
' TObject = class',
' i: byte;',
' procedure DoIt;',
' end;',
'procedure TObject.DoIt;',
'var',
' {#p}p: TProc;',
' procedure Sub;',
' begin',
' p:=procedure',
' begin',
' i:=3;',
' Self.i:=4;',
' p:=procedure',
' procedure SubSub;',
' begin',
' i:=13;',
' Self.i:=14;',
' end;',
' begin',
' i:=13;',
' Self.i:=14;',
' end;',
' end;',
' end;',
'begin',
'end;',
'begin']);
ParseProgram;

View File

@ -72,6 +72,7 @@ type
procedure TestM_NestedFuncResult;
procedure TestM_Enums;
procedure TestM_ProcedureType;
procedure TestM_AnonymousProc;
procedure TestM_Params;
procedure TestM_Class;
procedure TestM_ClassForward;
@ -999,6 +1000,27 @@ begin
AnalyzeProgram;
end;
procedure TTestUseAnalyzer.TestM_AnonymousProc;
begin
StartProgram(false);
Add([
'type',
' {#TProc_used}TProc = reference to procedure;',
'procedure {#DoIt_used}DoIt;',
'var',
' {#p_used}p: TProc;',
' {#i_used}i: longint;',
'begin',
' p:=procedure',
' begin',
' i:=3;',
' end;',
'end;',
'begin',
' DoIt;']);
AnalyzeProgram;
end;
procedure TTestUseAnalyzer.TestM_Params;
begin
StartProgram(false);

View File

@ -116,8 +116,7 @@ begin
OrigSrc:=JSFile.Source;
// compile, using .pcu files
//for i:=0 to FileCount-1 do
// writeln('AAA1 TCustomTestCLI_Precompile.CheckPrecompile ',i,' ',Files[i].Filename);
// writeln('TCustomTestCLI_Precompile.CheckPrecompile ',i,' ',Files[i].Filename);
{$IFDEF VerbosePCUFiler}
writeln('TTestCLI_Precompile.CheckPrecompile compile using pcu files==================');
{$ENDIF}