fcl-passrc: parser: position of generic function is in front of type params

git-svn-id: trunk@43056 -

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;

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

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
+    procedure TestGenProc_CallSelf;
-    // ToDo: forward parametrized impl overloads
+    procedure TestGenProc_ForwardConstraints;
-    // ToDo: parametrized nested proc fail
+    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 <T> <S,T>
     // ToDo: generic class method overload <T>(bool) <T>(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<T>(a: T): T;',
+    '']),
+    LinesToStr([
+    'generic function Fly<T>(a: T): T;',
+    'var i: T;',
+    'begin',
+    '  i:=a;',
+    'end;',
+    '']));
+  StartProgram(true);
+  Add([
+  'uses unit2;',
+  'var w: word;',
+  'begin',
+  '  w:=specialize Fly<word>(3);',
+  '  if specialize Fly<boolean>(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<T>(a: T): T;',
+  '  procedure Run;',
+  '  begin',
+  '    specialize Fly<T>(a);',
+  '    specialize Fly<word>(3);',
+  '  end;',
+  'begin',
+  '  specialize Fly<T>(a);',
+  '  specialize Fly<boolean>(true);',
+  'end;',
+  'begin',
+  '  specialize Fly<string>(''fast'');',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolveGenerics.TestGenProc_ForwardConstraints;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  '  TBird = class end;',
+  'var b: TBird;',
+  'generic function Fly<T: class>(a: T): T; forward;',
+  'procedure Run;',
+  'begin',
+  '  specialize Fly<TBird>(b);',
+  'end;',
+  'generic function Fly<T>(a: T): T;',
+  'begin',
+  'end;',
+  'begin',
+  '  specialize Fly<TBird>(b);',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolveGenerics.TestGenProc_ForwardConstraintsRepeatFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class end;',
+  'generic function Fly<T: class>(a: T): T; forward;',
+  'generic function Fly<T: class>(a: T): T;',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException(sImplMustNotRepeatConstraints,nImplMustNotRepeatConstraints);
+end;
+
+procedure TTestResolveGenerics.TestGenProc_ForwardTempNameMismatch;
+begin
+  StartProgram(false);
+  Add([
+  'generic function Fly<T>(a: T): T; forward;',
+  'generic function Fly<B>(a: B): B;',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException('Declaration of "Fly<B>" differs from previous declaration at afile.pp(2,23)',
+    nDeclOfXDiffersFromPrevAtY);
+end;
+
+procedure TTestResolveGenerics.TestGenProc_ForwardOverload;
+begin
+  StartProgram(false);
+  Add([
+  'generic function {#FlyA}Fly<T>(a: T; b: boolean): T; forward; overload;',
+  'generic function {#FlyB}Fly<T>(a: T; w: word): T; forward; overload;',
+  'procedure {#FlyC}Fly; overload;',
+  'begin',
+  '  specialize {@FlyA}Fly<longint>(1,true);',
+  '  specialize {@FlyB}Fly<string>(''ABC'',3);',
+  'end;',
+  'generic function Fly<T>(a: T; b: boolean): T;',
+  'begin',
+  'end;',
+  'generic function Fly<T>(a: T; w: word): T;',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolveGenerics.TestGenProc_NestedFail;
+begin
+  StartProgram(false);
+  Add([
+  'procedure Fly;',
+  '  generic procedure Run<T>(a: T);',
+  '  begin',
+  '  end;',
+  'begin',
+  '  Run<boolean>(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<T>(a: T);',
+  '  begin',
+  '  end;',
+  'begin',
+  '  Run<boolean>(true);',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException('Type parameters not allowed on nested procedure',nTypeParamsNotAllowedOnX);
+end;
+
 initialization
   RegisterTests([TTestResolveGenerics]);