From 8d1989fc9a261715c0188be4902a3255cfda361d Mon Sep 17 00:00:00 2001 From: mattias Date: Wed, 9 Feb 2022 22:05:41 +0100 Subject: [PATCH] fcl-passrc: fixed generic method with Self do --- packages/fcl-passrc/src/pasresolver.pp | 11 ++-- packages/pastojs/tests/tcgenerics.pas | 83 ++++++++++++++++++++++++-- 2 files changed, 82 insertions(+), 12 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index b0f85c1776..cb9ec9ea81 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -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; diff --git a/packages/pastojs/tests/tcgenerics.pas b/packages/pastojs/tests/tcgenerics.pas index c34a9c32f3..32dea543e3 100644 --- a/packages/pastojs/tests/tcgenerics.pas +++ b/packages/pastojs/tests/tcgenerics.pas @@ -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, TBird + Procedure TestGen_Class_TypeOverload; Procedure TestGen_Class_ClassProperty; Procedure TestGen_Class_ClassProc; - //Procedure TestGen_Record_ReferGenClass_DelphiFail; TBird = 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");', @@ -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");', + '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 = class', + ' var x: TPoint;', // alowed in objfpc, forbidden in delphi + ' end;', + 'var p: specialize TPoint;', + '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 = procedure(a, b: T);', + ' TProc = procedure(a: S; b: T);', + 'var', + ' p: TProc;', + ' q: TProc;', + '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", {', + ' procsig: rtl.newTIProcSig([["a", rtl.word], ["b", rtl.word]])', + '});', + 'this.p = null;', + 'this.$rtti.$ProcVar("TProc", {', + ' 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.