paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-01 21:30:35 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: fixed generic method with Self do

Browse Source
This commit is contained in:
mattias 2022-02-09 22:05:41 +01:00
parent 3827889e61
commit 8d1989fc9a
2 changed files with 82 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2235,7 +2235,7 @@ type
function HasExactType(const ResolvedEl: TPasResolverResult): boolean; // false if HiTypeEl was guessed, e.g. 1 guessed a btLongint
function IndexOfGenericParam(Params: TPasExprArray): integer;
procedure CheckUseAsType(aType: TPasElement; id: TMaxPrecInt;
ErrorEl: TPasElement);
PosEl: TPasElement);
function CheckCallProcCompatibility(ProcType: TPasProcedureType;
Params: TParamsExpr; RaiseOnError: boolean; SetReferenceFlags: boolean = false): integer;
function CheckCallPropertyCompatibility(PropEl: TPasProperty;
@ -22964,7 +22964,6 @@ begin
[BaseTypeNames[ExprResolved.BaseType]],ErrorEl);
Flags:=[];
CheckUseAsType(LoType,20190123113957,Expr);
ClassRecScope:=nil;
ExprScope:=nil;
if LoType.ClassType=TPasClassOfType then
@ -28424,7 +28423,7 @@ begin
end;
procedure TPasResolver.CheckUseAsType(aType: TPasElement; id: TMaxPrecInt;
ErrorEl: TPasElement);
PosEl: TPasElement);
begin
if aType=nil then exit;
if aType is TPasGenericType then
@ -28432,18 +28431,18 @@ begin
if aType.ClassType=TPasClassType then
begin
if TPasClassType(aType).HelperForType<>nil then
RaiseHelpersCannotBeUsedAsType(id,ErrorEl);
RaiseHelpersCannotBeUsedAsType(id,PosEl);
end;
if (TPasGenericType(aType).GenericTemplateTypes<>nil)
and (TPasGenericType(aType).GenericTemplateTypes.Count>0) then
begin
// ref to generic type without specialization
if not (msDelphi in CurrentParser.CurrentModeswitches)
and (ErrorEl.HasParent(aType)) then
and (PosEl.HasParent(aType)) then
// ObjFPC allows referring to parent without type params
else
RaiseMsg(id,nGenericsWithoutSpecializationAsType,sGenericsWithoutSpecializationAsType,
[ErrorEl.ElementTypeName],ErrorEl);
[PosEl.ElementTypeName],PosEl);
end;
end;
end;

83
packages/pastojs/tests/tcgenerics.pas
View File

@ -27,13 +27,13 @@ type
Procedure TestGen_ClassEmpty;
Procedure TestGen_Class_EmptyMethod;
Procedure TestGen_Class_TList;
Procedure TestGen_Class_TCustomList; // ToDo: with Self do Result:=Method()
Procedure TestGen_Class_TCustomList;
Procedure TestGen_ClassAncestor;
Procedure TestGen_Class_TypeInfo;
Procedure TestGen_Class_TypeOverload; // ToDo TBird, TBird<T>, TBird<S,T>
Procedure TestGen_Class_TypeOverload;
Procedure TestGen_Class_ClassProperty;
Procedure TestGen_Class_ClassProc;
//Procedure TestGen_Record_ReferGenClass_DelphiFail; TBird<T> = class x:TBird; end;
Procedure TestGen_Class_ReferGenClass_DelphiFail;
Procedure TestGen_Class_ClassConstructor;
Procedure TestGen_Class_TypeCastSpecializesWarn;
Procedure TestGen_Class_TypeCastSpecializesJSValueNoWarn;
@ -92,6 +92,8 @@ type
procedure TestGen_ProcType_ProcLocal;
procedure TestGen_ProcType_Local_RTTI_Fail;
procedure TestGen_ProcType_ParamUnitImpl;
// procedure TestGen_ProcType_TemplateCountOverload_ObjFPC; ObjFPC does not support that in FPC
procedure TestGen_ProcType_TemplateCountOverload_Delphi;
end;
implementation
@ -574,7 +576,7 @@ begin
'begin',
' Result:=PrepareAddingItem;',
' Result:=Self.PrepareAddingItem;',
//' with Self do Result:=PrepareAddingItem;',
' with Self do Result:=PrepareAddingItem;',
'end;',
'var l: TWordList;',
'begin',
@ -599,6 +601,7 @@ begin
' var Result = 0;',
' Result = this.PrepareAddingItem();',
' Result = this.PrepareAddingItem();',
' Result = this.PrepareAddingItem();',
' return Result;',
' };',
'}, "TList<System.Word>");',
@ -688,8 +691,6 @@ end;
procedure TTestGenerics.TestGen_Class_TypeOverload;
begin
exit;// ToDo
StartProgram(false);
Add([
'{$mode delphi}',
@ -714,6 +715,14 @@ begin
' this.$final = function () {',
' };',
'});',
'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
' this.$init = function () {',
' $mod.TObject.$init.call(this);',
' this.m = 0;',
' };',
'}, "TBird<System.Word>");',
'this.b = null;',
'this.e = null;',
'']),
LinesToStr([ // $mod.$main
'']));
@ -820,6 +829,24 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_Class_ReferGenClass_DelphiFail;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TObject = class end;',
' TPoint<T> = class',
' var x: TPoint;', // alowed in objfpc, forbidden in delphi
' end;',
'var p: specialize TPoint<word>;',
'begin',
'']);
SetExpectedPasResolverError('Generics without specialization cannot be used as a type for a variable',
nGenericsWithoutSpecializationAsType);
ConvertProgram;
end;
procedure TTestGenerics.TestGen_Class_ClassConstructor;
begin
StartProgram(false);
@ -2865,6 +2892,50 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_ProcType_TemplateCountOverload_Delphi;
begin
WithTypeInfo:=true;
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TProc<T> = procedure(a, b: T);',
' TProc<S,T> = procedure(a: S; b: T);',
'var',
' p: TProc<word>;',
' q: TProc<char,boolean>;',
'procedure Run(x,y: word);',
'begin',
'end;',
'procedure Fly(x: char; y: boolean);',
'begin',
'end;',
'begin',
' p:=Run;',
' q:=Fly;',
'end.']);
ConvertProgram;
CheckSource('TestGen_ProcType_TemplateCountOverload_Delphi',
LinesToStr([ // statements
'this.$rtti.$ProcVar("TProc<System.Word>", {',
' procsig: rtl.newTIProcSig([["a", rtl.word], ["b", rtl.word]])',
'});',
'this.p = null;',
'this.$rtti.$ProcVar("TProc<System.Char,System.Boolean>", {',
' procsig: rtl.newTIProcSig([["a", rtl.char], ["b", rtl.boolean]])',
'});',
'this.q = null;',
'this.Run = function (x, y) {',
'};',
'this.Fly = function (x, y) {',
'};',
'']),
LinesToStr([ // $mod.$main
'$mod.p = $mod.Run;',
'$mod.q = $mod.Fly;',
'']));
end;
Initialization
RegisterTests([TTestGenerics]);
end.