mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-13 09:59:25 +02:00
fcl-passrc: anonymous procedure type
(cherry picked from commit 4181e24ea4)
This commit is contained in:
mattias
Mattias Gaertner
parent
4c3ec5b30f
commit
e9de16aaa1
@ -1665,6 +1665,7 @@ type
|
||||
procedure AccessExpr(Expr: TPasExpr; Access: TResolvedRefAccess);
|
||||
function MarkArrayExpr(Expr: TParamsExpr; ArrayType: TPasArrayType): boolean; virtual;
|
||||
procedure MarkArrayExprRecursive(Expr: TPasExpr; ArrType: TPasArrayType); virtual;
|
||||
procedure DeanonymizeType(El: TPasType); virtual;
|
||||
procedure FinishModule(CurModule: TPasModule); virtual;
|
||||
procedure FinishUsesClause; virtual;
|
||||
procedure FinishSection(Section: TPasSection); virtual;
|
||||
@ -6303,82 +6304,15 @@ begin
|
||||
end;
|
||||
|
||||
procedure TPasResolver.FinishSubElementType(Parent: TPasElement; El: TPasType);
|
||||
|
||||
procedure InsertInFront(NewParent: TPasElement; List: TFPList
|
||||
{$IFDEF CheckPasTreeRefCount};const aId: string{$ENDIF});
|
||||
var
|
||||
i: Integer;
|
||||
p, Prev: TPasElement;
|
||||
begin
|
||||
p:=El.Parent;
|
||||
if NewParent=p.Parent then
|
||||
begin
|
||||
// e.g. m,n:array of longint; -> insert n$a in front of m
|
||||
i:=List.Count-1;
|
||||
while (i>=0) and (List[i]<>Pointer(p)) do
|
||||
dec(i);
|
||||
if P is TPasVariable then
|
||||
begin
|
||||
while (i>0) do
|
||||
begin
|
||||
Prev:=TPasElement(List[i-1]);
|
||||
if (Prev.ClassType=P.ClassType) and (TPasVariable(Prev).VarType=TPasVariable(P).VarType) then
|
||||
dec(i) // e.g. m,n: array of longint
|
||||
else
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
if i<0 then
|
||||
List.Add(El)
|
||||
else
|
||||
List.Insert(i,El);
|
||||
end
|
||||
else
|
||||
begin
|
||||
List.Add(El);
|
||||
end;
|
||||
El.AddRef{$IFDEF CheckPasTreeRefCount}(aID){$ENDIF};
|
||||
El.Parent:=NewParent;
|
||||
end;
|
||||
|
||||
var
|
||||
Decl: TPasDeclarations;
|
||||
EnumScope: TPasEnumTypeScope;
|
||||
p: TPasElement;
|
||||
MembersType: TPasMembersType;
|
||||
begin
|
||||
EmitTypeHints(Parent,El);
|
||||
if (El.Name<>'') or (AnonymousElTypePostfix='') then exit;
|
||||
if Parent.Name='' then
|
||||
RaiseMsg(20170415165455,nCannotNestAnonymousX,sCannotNestAnonymousX,[GetElementTypeName(El)],El);
|
||||
if El.Parent<>Parent then
|
||||
RaiseNotYetImplemented(20190215085011,Parent);
|
||||
// give anonymous sub type a name
|
||||
El.Name:=Parent.Name+AnonymousElTypePostfix;
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.FinishSubElementType parent="',GetObjName(Parent),'" named anonymous type "',GetObjName(El),'"');
|
||||
{$ENDIF}
|
||||
RaiseNotYetImplemented(20220320123426,Parent,GetElementTypeName(El));
|
||||
DeanonymizeType(El);
|
||||
|
||||
p:=Parent.Parent;
|
||||
repeat
|
||||
if p is TPasDeclarations then
|
||||
begin
|
||||
Decl:=TPasDeclarations(p);
|
||||
InsertInFront(Decl,Decl.Declarations{$IFDEF CheckPasTreeRefCount},'TPasDeclarations.Declarations'{$ENDIF});
|
||||
Decl.Types.Add(El);
|
||||
break;
|
||||
end
|
||||
else if p is TPasMembersType then
|
||||
begin
|
||||
MembersType:=TPasMembersType(p);
|
||||
InsertInFront(MembersType,MembersType.Members{$IFDEF CheckPasTreeRefCount},'TPasMembersType.Members'{$ENDIF});
|
||||
break;
|
||||
end
|
||||
else
|
||||
p:=p.Parent;
|
||||
if p=nil then
|
||||
RaiseMsg(20170416094735,nCannotNestAnonymousX,sCannotNestAnonymousX,[GetElementTypeName(El)],El);
|
||||
until false;
|
||||
if (El.ClassType=TPasEnumType) and (Parent.ClassType=TPasSetType) then
|
||||
begin
|
||||
// anonymous enumtype
|
||||
@ -7408,9 +7342,7 @@ begin
|
||||
else if El.Name<>'' then
|
||||
begin
|
||||
// finished proc type, e.g. type TProcedure = procedure;
|
||||
end
|
||||
else
|
||||
RaiseNotYetImplemented(20160922163411,El.Parent,'anonymous procedure type');
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPasResolver.FinishMethodDeclHeader(Proc: TPasProcedure);
|
||||
@ -12097,6 +12029,91 @@ begin
|
||||
Traverse(Expr,ArrType,0);
|
||||
end;
|
||||
|
||||
procedure TPasResolver.DeanonymizeType(El: TPasType);
|
||||
|
||||
procedure InsertInFront(NewParent: TPasElement; List: TFPList
|
||||
{$IFDEF CheckPasTreeRefCount};const aId: string{$ENDIF});
|
||||
var
|
||||
i: Integer;
|
||||
p, Prev: TPasElement;
|
||||
begin
|
||||
p:=El.Parent;
|
||||
if NewParent=p.Parent then
|
||||
begin
|
||||
// e.g. m,n:array of longint; -> insert n$a in front of m
|
||||
i:=List.Count-1;
|
||||
while (i>=0) and (List[i]<>Pointer(p)) do
|
||||
dec(i);
|
||||
if P is TPasVariable then
|
||||
begin
|
||||
while (i>0) do
|
||||
begin
|
||||
Prev:=TPasElement(List[i-1]);
|
||||
if (Prev.ClassType=P.ClassType) and (TPasVariable(Prev).VarType=TPasVariable(P).VarType) then
|
||||
dec(i) // e.g. m,n: array of longint
|
||||
else
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
if i<0 then
|
||||
List.Add(El)
|
||||
else
|
||||
List.Insert(i,El);
|
||||
end
|
||||
else
|
||||
begin
|
||||
List.Add(El);
|
||||
end;
|
||||
El.AddRef{$IFDEF CheckPasTreeRefCount}(aID){$ENDIF};
|
||||
El.Parent:=NewParent;
|
||||
end;
|
||||
|
||||
var
|
||||
Decl: TPasDeclarations;
|
||||
p: TPasElement;
|
||||
MembersType: TPasMembersType;
|
||||
CurName: String;
|
||||
begin
|
||||
if (AnonymousElTypePostfix='') then
|
||||
exit;
|
||||
if (El.Name<>'') then
|
||||
RaiseNotYetImplemented(20220320121923,El);
|
||||
|
||||
CurName:='';
|
||||
p:=El.Parent;
|
||||
repeat
|
||||
if (p is TPasDeclarations) or (p is TPasMembersType) then
|
||||
begin
|
||||
if CurName='' then
|
||||
RaiseMsg(20220320122946,nCannotNestAnonymousX,sCannotNestAnonymousX,[GetElementTypeName(El)],El);
|
||||
El.Name:=CurName+AnonymousElTypePostfix;
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.DeanonymizeType named anonymous type "',GetObjPath(El),'"');
|
||||
{$ENDIF}
|
||||
if p is TPasDeclarations then
|
||||
begin
|
||||
Decl:=TPasDeclarations(p);
|
||||
InsertInFront(Decl,Decl.Declarations{$IFDEF CheckPasTreeRefCount},'TPasDeclarations.Declarations'{$ENDIF});
|
||||
Decl.Types.Add(El);
|
||||
end
|
||||
else if p is TPasMembersType then
|
||||
begin
|
||||
MembersType:=TPasMembersType(p);
|
||||
InsertInFront(MembersType,MembersType.Members{$IFDEF CheckPasTreeRefCount},'TPasMembersType.Members'{$ENDIF});
|
||||
end;
|
||||
break;
|
||||
end
|
||||
else if p.Name<>'' then
|
||||
begin
|
||||
if CurName<>'' then
|
||||
CurName:=p.Name+'__'+CurName
|
||||
else
|
||||
CurName:=p.Name;
|
||||
end;
|
||||
p:=p.Parent;
|
||||
until false;
|
||||
end;
|
||||
|
||||
procedure TPasResolver.CheckPointerCycle(El: TPasPointerType);
|
||||
var
|
||||
C: TClass;
|
||||
@ -12547,7 +12564,8 @@ procedure TPasResolver.AddProcedureType(El: TPasProcedureType;
|
||||
var
|
||||
Scope: TPasProcTypeScope;
|
||||
begin
|
||||
if El.Name<>'' then begin
|
||||
if El.Name<>'' then
|
||||
begin
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.AddProcedureType ',GetObjName(El),' Parent=',GetObjName(El.Parent));
|
||||
{$ENDIF}
|
||||
@ -12571,8 +12589,24 @@ begin
|
||||
Scope:=TPasProcTypeScope(PushScope(El,ScopeClass_ProcType));
|
||||
AddGenericTemplateIdentifiers(TypeParams,Scope);
|
||||
end;
|
||||
end else if TypeParams<>nil then
|
||||
RaiseNotYetImplemented(20190813193745,El);
|
||||
end
|
||||
else
|
||||
begin
|
||||
// no name
|
||||
if TypeParams<>nil then
|
||||
RaiseNotYetImplemented(20190813193745,El);
|
||||
if El.Parent=nil then
|
||||
RaiseNotYetImplemented(20220320122040,El);
|
||||
if El.Parent is TPasProcedure then
|
||||
// proctype of procedure has no name -> normal
|
||||
else
|
||||
begin
|
||||
// anonymous procedure type, e.g. "var p: procedure;"
|
||||
writeln('AAA1 TPasResolver.AddProcedureType ',GetObjPath(El));
|
||||
DeanonymizeType(El);
|
||||
writeln('AAA2 TPasResolver.AddProcedureType ',GetObjPath(El));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPasResolver.AddProcedure(El: TPasProcedure; TypeParams: TFPList);
|
||||
|
||||
@ -1163,7 +1163,7 @@ begin
|
||||
|
||||
TPasFunctionType(Result).ResultEl :=
|
||||
TPasResultElement(CreateElement(TPasResultElement, AResultName, ResultParent,
|
||||
visDefault, ASrcPos, TypeParams));
|
||||
visDefault, ASrcPos, TypeParams));
|
||||
end;
|
||||
|
||||
function TPasTreeContainer.FindElementFor(const AName: String;
|
||||
|
||||
@ -890,6 +890,9 @@ type
|
||||
Procedure TestProcType_InsideFunction;
|
||||
Procedure TestProcType_PassProcToUntyped;
|
||||
|
||||
// anonymous procedure type
|
||||
Procedure TestProcTypeAnonymous_FunctionFunctionFail; // ToDo
|
||||
|
||||
// pointer
|
||||
Procedure TestPointer;
|
||||
Procedure TestPointer_AnonymousSetFail;
|
||||
@ -15542,63 +15545,64 @@ end;
|
||||
procedure TTestResolver.TestProcTypesAssignObjFPC;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('type');
|
||||
Add(' TProcedure = procedure;');
|
||||
Add(' TFunctionInt = function:longint;');
|
||||
Add(' TFunctionIntFunc = function:TFunctionInt;');
|
||||
Add(' TFunctionIntFuncFunc = function:TFunctionIntFunc;');
|
||||
Add('function GetNumber: longint;');
|
||||
Add('begin');
|
||||
Add(' Result:=3;');
|
||||
Add('end;');
|
||||
Add('function GetNumberFunc: TFunctionInt;');
|
||||
Add('begin');
|
||||
Add(' Result:=@GetNumber;');
|
||||
Add('end;');
|
||||
Add('function GetNumberFuncFunc: TFunctionIntFunc;');
|
||||
Add('begin');
|
||||
Add(' Result:=@GetNumberFunc;');
|
||||
Add('end;');
|
||||
Add('var');
|
||||
Add(' i: longint;');
|
||||
Add(' f: TFunctionInt;');
|
||||
Add(' ff: TFunctionIntFunc;');
|
||||
Add('begin');
|
||||
Add(' i:=GetNumber; // omit ()');
|
||||
Add(' i:=GetNumber();');
|
||||
Add(' i:=GetNumberFunc()();');
|
||||
Add(' i:=GetNumberFuncFunc()()();');
|
||||
Add(' if i=GetNumberFunc()() then ;');
|
||||
Add(' if GetNumberFunc()()=i then ;');
|
||||
Add(' if i=GetNumberFuncFunc()()() then ;');
|
||||
Add(' if GetNumberFuncFunc()()()=i then ;');
|
||||
Add(' f:=nil;');
|
||||
Add(' if f=nil then ;');
|
||||
Add(' if nil=f then ;');
|
||||
Add(' if Assigned(f) then ;');
|
||||
Add(' f:=f;');
|
||||
Add(' f:=@GetNumber;');
|
||||
Add(' f:=GetNumberFunc; // not in Delphi');
|
||||
Add(' f:=GetNumberFunc(); // not in Delphi');
|
||||
Add(' f:=GetNumberFuncFunc()();');
|
||||
Add(' if f=f then ;');
|
||||
Add(' if i=f then ;');
|
||||
Add(' if i=f() then ;');
|
||||
Add(' if f()=i then ;');
|
||||
Add(' if f()=f() then ;');
|
||||
Add(' if f=@GetNumber then ;');
|
||||
Add(' if @GetNumber=f then ;');
|
||||
Add(' if f=GetNumberFunc then ;');
|
||||
Add(' if f=GetNumberFunc() then ;');
|
||||
Add(' if f=GetNumberFuncFunc()() then ;');
|
||||
Add(' ff:=nil;');
|
||||
Add(' if ff=nil then ;');
|
||||
Add(' if nil=ff then ;');
|
||||
Add(' ff:=ff;');
|
||||
Add(' if ff=ff then ;');
|
||||
Add(' ff:=@GetNumberFunc;');
|
||||
Add(' ff:=GetNumberFuncFunc; // not in Delphi');
|
||||
Add(' ff:=GetNumberFuncFunc();');
|
||||
Add([
|
||||
'type',
|
||||
' TProcedure = procedure;',
|
||||
' TFunctionInt = function:longint;',
|
||||
' TFunctionIntFunc = function:TFunctionInt;',
|
||||
' TFunctionIntFuncFunc = function:TFunctionIntFunc;',
|
||||
'function GetNumber: longint;',
|
||||
'begin',
|
||||
' Result:=3;',
|
||||
'end;',
|
||||
'function GetNumberFunc: TFunctionInt;',
|
||||
'begin',
|
||||
' Result:=@GetNumber;',
|
||||
'end;',
|
||||
'function GetNumberFuncFunc: TFunctionIntFunc;',
|
||||
'begin',
|
||||
' Result:=@GetNumberFunc;',
|
||||
'end;',
|
||||
'var',
|
||||
' i: longint;',
|
||||
' f: TFunctionInt;',
|
||||
' ff: TFunctionIntFunc;',
|
||||
'begin',
|
||||
' i:=GetNumber; // omit ()',
|
||||
' i:=GetNumber();',
|
||||
' i:=GetNumberFunc()();',
|
||||
' i:=GetNumberFuncFunc()()();',
|
||||
' if i=GetNumberFunc()() then ;',
|
||||
' if GetNumberFunc()()=i then ;',
|
||||
' if i=GetNumberFuncFunc()()() then ;',
|
||||
' if GetNumberFuncFunc()()()=i then ;',
|
||||
' f:=nil;',
|
||||
' if f=nil then ;',
|
||||
' if nil=f then ;',
|
||||
' if Assigned(f) then ;',
|
||||
' f:=f;',
|
||||
' f:=@GetNumber;',
|
||||
' f:=GetNumberFunc; // not in Delphi',
|
||||
' f:=GetNumberFunc(); // not in Delphi',
|
||||
' f:=GetNumberFuncFunc()();',
|
||||
' if f=f then ;',
|
||||
' if i=f then ;',
|
||||
' if i=f() then ;',
|
||||
' if f()=i then ;',
|
||||
' if f()=f() then ;',
|
||||
' if f=@GetNumber then ;',
|
||||
' if @GetNumber=f then ;',
|
||||
' if f=GetNumberFunc then ;',
|
||||
' if f=GetNumberFunc() then ;',
|
||||
' if f=GetNumberFuncFunc()() then ;',
|
||||
' ff:=nil;',
|
||||
' if ff=nil then ;',
|
||||
' if nil=ff then ;',
|
||||
' ff:=ff;',
|
||||
' if ff=ff then ;',
|
||||
' ff:=@GetNumberFunc;',
|
||||
' ff:=GetNumberFuncFunc; // not in Delphi',
|
||||
' ff:=GetNumberFuncFunc();']);
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
@ -16520,6 +16524,19 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestProcTypeAnonymous_FunctionFunctionFail;
|
||||
begin
|
||||
exit;
|
||||
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'var',
|
||||
' f: function:function:longint;',
|
||||
'begin']);
|
||||
CheckParserException('Expected "Identifier or file"',
|
||||
nParserExpectTokenError);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestPointer;
|
||||
begin
|
||||
StartProgram(false);
|
||||
|
||||
@ -847,6 +847,7 @@ type
|
||||
Procedure TestRTTI_Double;
|
||||
Procedure TestRTTI_ProcType;
|
||||
Procedure TestRTTI_ProcType_ArgFromOtherUnit;
|
||||
Procedure TestRTTI_ProcTypeAnonymous;
|
||||
Procedure TestRTTI_EnumAndSetType;
|
||||
Procedure TestRTTI_EnumRange;
|
||||
Procedure TestRTTI_AnonymousEnumType;
|
||||
@ -30428,6 +30429,50 @@ begin
|
||||
'']) );
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestRTTI_ProcTypeAnonymous;
|
||||
begin
|
||||
WithTypeInfo:=true;
|
||||
StartProgram(false);
|
||||
Add(['var',
|
||||
' ProcA: procedure;',
|
||||
' MethodB: procedure of object;',
|
||||
' ProcC: procedure; varargs;',
|
||||
' ProcD: procedure(i: longint; const j: string; var c: char; out d: double);',
|
||||
' ProcE: function: nativeint;',
|
||||
' p: pointer;',
|
||||
'begin',
|
||||
' p:=typeinfo(proca);']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestRTTI_ProcTypeAnonymous',
|
||||
LinesToStr([ // statements
|
||||
'this.$rtti.$ProcVar("ProcA$a", {',
|
||||
' procsig: rtl.newTIProcSig([])',
|
||||
'});',
|
||||
'this.ProcA = null;',
|
||||
'this.$rtti.$MethodVar("MethodB$a", {',
|
||||
' procsig: rtl.newTIProcSig([]),',
|
||||
' methodkind: 0',
|
||||
'});',
|
||||
'this.MethodB = null;',
|
||||
'this.$rtti.$ProcVar("ProcC$a", {',
|
||||
' procsig: rtl.newTIProcSig([], null, 2)',
|
||||
'});',
|
||||
'this.ProcC = null;',
|
||||
'this.$rtti.$ProcVar("ProcD$a", {',
|
||||
' procsig: rtl.newTIProcSig([["i", rtl.longint], ["j", rtl.string, 2], ["c", rtl.char, 1], ["d", rtl.double, 4]])',
|
||||
'});',
|
||||
'this.ProcD = null;',
|
||||
'this.$rtti.$ProcVar("ProcE$a", {',
|
||||
' procsig: rtl.newTIProcSig([], rtl.nativeint)',
|
||||
'});',
|
||||
'this.ProcE = null;',
|
||||
'this.p = null;',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'$mod.p = $mod.$rtti["ProcA$a"];',
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestRTTI_EnumAndSetType;
|
||||
begin
|
||||
WithTypeInfo:=true;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user