diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 5046816d79..18ec73b4bf 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -5097,7 +5097,7 @@ var end; begin - writeln('TPasResolver.OnFindProc START ',El.Name,':',GetElementTypeName(El),' itself=',El=Data^.Proc); + //writeln('TPasResolver.OnFindProc START ',El.Name,':',GetElementTypeName(El),' itself=',El=Data^.Proc); if not (El is TPasProcedure) then begin // identifier is not a proc @@ -8974,7 +8974,6 @@ begin DeclTemplates:=GetProcTemplateTypes(DeclProc); if ImplTemplates<>nil then begin - writeln('AAA1 TPasResolver.ReplaceProcScopeImplArgsWithDeclArgs DeclProc=',DeclProc.Name,' ImplProc=',ImplProc.Name,' ',ImplTemplates.Count); if (DeclTemplates=nil) or (ImplTemplates.Count<>DeclTemplates.Count) then RaiseNotYetImplemented(20190912153602,ImplProc); // inconsistency for i:=0 to ImplTemplates.Count-1 do @@ -15877,8 +15876,12 @@ var begin {$IF defined(VerbosePasResolver) or defined(VerbosePas2JS)} writeln('InsertBehind Generic=',GetObjName(GenericEl),' Last=',GetObjName(Last)); + //for i:=0 to List.Count-1 do writeln(' ',GetObjName(TObject(List[i]))); {$ENDIF} - RaiseNotYetImplemented(20190826150507,El); + if GenericEl is TPasProcedure then + i:=List.Count-1 + else + RaiseNotYetImplemented(20190826150507,El); end; List.Insert(i+1,NewEl); end; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index ff946f1789..fa795087be 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -6365,6 +6365,7 @@ function TPasParser.ParseProcedureOrFunctionDecl(Parent: TPasElement; ): TPasProcedure; var NameParts: TProcedureNameParts; + NamePos: TPasSourcePos; function ExpectProcName: string; { Simple procedure: @@ -6388,6 +6389,7 @@ var Part: TProcedureNamePart; begin Result:=ExpectIdentifier; + NamePos:=CurSourcePos; Cnt:=1; repeat NextToken; @@ -6397,6 +6399,7 @@ var begin inc(Cnt); CurName:=ExpectIdentifier; + NamePos:=CurSourcePos; Result:=Result+'.'+CurName; if NameParts<>nil then begin @@ -6476,12 +6479,14 @@ begin if (ot=otUnknown) then ParseExc(nErrUnknownOperatorType,SErrUnknownOperatorType,[CurTokenString]); Name:=OperatorNames[Ot]; + NamePos:=CurTokenPos; end; ptAnonymousProcedure,ptAnonymousFunction: begin Name:=''; if MustBeGeneric then ParseExcTokenError('generic'); // inconsistency + NamePos:=CurTokenPos; end else Name:=ExpectProcName; @@ -6490,7 +6495,7 @@ begin if Name<>'' then Parent:=CheckIfOverLoaded(Parent,Name); Result := TPasProcedure(Engine.CreateElement(PC, Name, Parent, AVisibility, - CurSourcePos, NameParts)); + NamePos, NameParts)); if NameParts<>nil then begin if Result.NameParts=nil then diff --git a/packages/fcl-passrc/tests/tcresolvegenerics.pas b/packages/fcl-passrc/tests/tcresolvegenerics.pas index ad8538b923..eb8343be9c 100644 --- a/packages/fcl-passrc/tests/tcresolvegenerics.pas +++ b/packages/fcl-passrc/tests/tcresolvegenerics.pas @@ -125,17 +125,21 @@ type procedure TestGenProc_MissingTemplatesFail; procedure TestGenProc_Forward; procedure TestGenProc_External; - //procedure TestGenProc_UnitIntf; + procedure TestGenProc_UnitIntf; procedure TestGenProc_BackRef1Fail; procedure TestGenProc_BackRef2Fail; procedure TestGenProc_BackRef3Fail; //procedure TestGenProc_Inference; - // ToDo: forward parametrized impl must not repeat constraints - // ToDo: forward parametrized impl overloads - // ToDo: parametrized nested proc fail + procedure TestGenProc_CallSelf; + procedure TestGenProc_ForwardConstraints; + procedure TestGenProc_ForwardConstraintsRepeatFail; + procedure TestGenProc_ForwardTempNameMismatch; + procedure TestGenProc_ForwardOverload; + procedure TestGenProc_NestedFail; + procedure TestGenMethod_VirtualFail; // ToDo: virtual method cannot have type parameters // ToDo: message method cannot have type parameters - // ToDo: interface method cannot have type parameters + // ToDo: class interface method cannot have type parameters // ToDo: parametrized method mismatch interface method // ToDo: generic class method overload // ToDo: generic class method overload (bool) (word) @@ -1747,7 +1751,7 @@ begin 'end;', 'begin', '']); - CheckResolverException('Duplicate identifier "Fly" at afile.pp(2,25)',nDuplicateIdentifier); + CheckResolverException('Duplicate identifier "Fly" at afile.pp(2,22)',nDuplicateIdentifier); end; procedure TTestResolveGenerics.TestGenProc_MissingTemplatesFail; @@ -1797,6 +1801,30 @@ begin ParseProgram; end; +procedure TTestResolveGenerics.TestGenProc_UnitIntf; +begin + AddModuleWithIntfImplSrc('unit2.pas', + LinesToStr([ + 'generic function Fly(a: T): T;', + '']), + LinesToStr([ + 'generic function Fly(a: T): T;', + 'var i: T;', + 'begin', + ' i:=a;', + 'end;', + ''])); + StartProgram(true); + Add([ + 'uses unit2;', + 'var w: word;', + 'begin', + ' w:=specialize Fly(3);', + ' if specialize Fly(false) then ;', + '']); + ParseProgram; +end; + procedure TTestResolveGenerics.TestGenProc_BackRef1Fail; begin StartProgram(false); @@ -1833,6 +1861,131 @@ begin CheckResolverException('Wrong number of parameters specified for call to "function Fly<>(untyped)"',nWrongNumberOfParametersForCallTo); end; +procedure TTestResolveGenerics.TestGenProc_CallSelf; +begin + StartProgram(false); + Add([ + 'generic function Fly(a: T): T;', + ' procedure Run;', + ' begin', + ' specialize Fly(a);', + ' specialize Fly(3);', + ' end;', + 'begin', + ' specialize Fly(a);', + ' specialize Fly(true);', + 'end;', + 'begin', + ' specialize Fly(''fast'');', + '']); + ParseProgram; +end; + +procedure TTestResolveGenerics.TestGenProc_ForwardConstraints; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class end;', + ' TBird = class end;', + 'var b: TBird;', + 'generic function Fly(a: T): T; forward;', + 'procedure Run;', + 'begin', + ' specialize Fly(b);', + 'end;', + 'generic function Fly(a: T): T;', + 'begin', + 'end;', + 'begin', + ' specialize Fly(b);', + '']); + ParseProgram; +end; + +procedure TTestResolveGenerics.TestGenProc_ForwardConstraintsRepeatFail; +begin + StartProgram(false); + Add([ + 'type', + ' TObject = class end;', + 'generic function Fly(a: T): T; forward;', + 'generic function Fly(a: T): T;', + 'begin', + 'end;', + 'begin', + '']); + CheckResolverException(sImplMustNotRepeatConstraints,nImplMustNotRepeatConstraints); +end; + +procedure TTestResolveGenerics.TestGenProc_ForwardTempNameMismatch; +begin + StartProgram(false); + Add([ + 'generic function Fly(a: T): T; forward;', + 'generic function Fly(a: B): B;', + 'begin', + 'end;', + 'begin', + '']); + CheckResolverException('Declaration of "Fly" differs from previous declaration at afile.pp(2,23)', + nDeclOfXDiffersFromPrevAtY); +end; + +procedure TTestResolveGenerics.TestGenProc_ForwardOverload; +begin + StartProgram(false); + Add([ + 'generic function {#FlyA}Fly(a: T; b: boolean): T; forward; overload;', + 'generic function {#FlyB}Fly(a: T; w: word): T; forward; overload;', + 'procedure {#FlyC}Fly; overload;', + 'begin', + ' specialize {@FlyA}Fly(1,true);', + ' specialize {@FlyB}Fly(''ABC'',3);', + 'end;', + 'generic function Fly(a: T; b: boolean): T;', + 'begin', + 'end;', + 'generic function Fly(a: T; w: word): T;', + 'begin', + 'end;', + 'begin', + '']); + ParseProgram; +end; + +procedure TTestResolveGenerics.TestGenProc_NestedFail; +begin + StartProgram(false); + Add([ + 'procedure Fly;', + ' generic procedure Run(a: T);', + ' begin', + ' end;', + 'begin', + ' Run(true);', + 'end;', + 'begin', + '']); + CheckResolverException('Type parameters not allowed on nested procedure',nTypeParamsNotAllowedOnX); +end; + +procedure TTestResolveGenerics.TestGenMethod_VirtualFail; +begin + StartProgram(false); + Add([ + 'procedure Fly;', + ' generic procedure Run(a: T);', + ' begin', + ' end;', + 'begin', + ' Run(true);', + 'end;', + 'begin', + '']); + CheckResolverException('Type parameters not allowed on nested procedure',nTypeParamsNotAllowedOnX); +end; + initialization RegisterTests([TTestResolveGenerics]);