fcl-passrc: specialize generic method

git-svn-id: trunk@43090 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1761,6 +1761,11 @@ type
     function EvalBaseTypeCast(Params: TParamsExpr; bt: TResolverBaseType): TResEvalvalue;
   protected
     // generic/specialize
+    type
+      TScopeStashState = record
+        ScopeCount: integer;
+        StashCount: integer;
+      end;
     procedure AddGenericTemplateIdentifiers(GenericTemplateTypes: TFPList;
       Scope: TPasIdentifierScope);
     procedure AddSpecializedTemplateIdentifiers(GenericTemplateTypes: TFPList;
@@ -1789,7 +1794,8 @@ type
       GenTempl: TPasGenericTemplateType; ErrorPos: TPasElement);
     function CreateSpecializedItem(El: TPasElement; GenericEl: TPasElement;
       const ParamsResolved: TPasTypeArray): TPRSpecializedItem; virtual;
-    function InitSpecializeScopes(El: TPasElement): integer; virtual;
+    procedure InitSpecializeScopes(El: TPasElement; out State: TScopeStashState); virtual;
+    procedure RestoreSpecializeScopes(const State: TScopeStashState); virtual;
     procedure SpecializeGenericIntf(SpecializedItem: TPRSpecializedItem); virtual;
     procedure SpecializeGenericImpl(SpecializedItem: TPRSpecializedItem); virtual;
     procedure SpecializeMembers(GenMembersType, SpecMembersType: TPasMembersType); virtual;
@@ -6027,7 +6033,7 @@ type
   end;
 var
   ClassScope: TPasClassScope;
-  i, j, k, OldStashCount: Integer;
+  i, j, k: Integer;
   IntfType: TPasClassType;
   Resolutions: array of TMethResolution;
   Map: TPasClassIntfMap;
@@ -6043,6 +6049,7 @@ var
   SectionScope: TPasSectionScope;
   SpecializedItems: TObjectList;
   SpecializedItem: TPRSpecializedTypeItem;
+  OldScopeState: TScopeStashState;
 begin
   Resolutions:=nil;
   ClassScope:=nil;
@@ -6218,7 +6225,7 @@ begin
         SpecializedItem:=TPRSpecializedTypeItem(SpecializedItems[i]);
         SpecializedItem.GenericEl:=El;
         if SpecializedItem.Step<>prssNone then continue;
-        OldStashCount:=InitSpecializeScopes(El);
+        InitSpecializeScopes(El,OldScopeState);
         {$IFDEF VerbosePasResolver}
         WriteScopesShort('TPasResolver.FinishClassType Finishing specialize interface: '+GetObjName(SpecializedItem.SpecializedType));
         {$ENDIF}
@@ -6228,7 +6235,7 @@ begin
         WriteScopesShort('TPasResolver.FinishClassType Finished specialize interface: '+GetObjName(SpecializedItem.SpecializedType));
         {$ENDIF}
 
-        RestoreStashedScopes(OldStashCount);
+        RestoreSpecializeScopes(OldScopeState);
         {$IFDEF VerbosePasResolver}
         WriteScopesShort('TPasResolver.FinishClassType RestoreStashedScopes '+GetObjName(SpecializedItem.SpecializedType));
         {$ENDIF}
@@ -7026,13 +7033,16 @@ begin
   ProcScope.ClassRecScope:=ClassOrRecScope;
 
   TemplTypes:=GetProcTemplateTypes(Proc);
-  if TemplTypes<>nil then
-    RaiseNotYetImplemented(20190911105953,Proc);
 
   FindData:=Default(TFindProcData);
   IsClassConDestructor:=(Proc.ClassType=TPasClassConstructor)
                      or (Proc.ClassType=TPasClassDestructor);
-  if not IsClassConDestructor then
+  if IsClassConDestructor then
+    begin
+    if TemplTypes<>nil then
+      RaiseNotYetImplemented(20190911105953,Proc);
+    end
+  else
     begin
     FindData.Proc:=Proc;
     FindData.Args:=Proc.ProcType.Args;
@@ -7107,7 +7117,7 @@ var
   SelfArg: TPasArgument;
   p: Integer;
   SelfType, LoSelfType: TPasType;
-  ImplTemplTypes: TFPList;
+  LastNamePart: TProcedureNamePart;
 begin
   if ImplProc.IsExternal then
     RaiseMsg(20170216151715,nInvalidXModifierY,sInvalidXModifierY,[GetElementTypeName(ImplProc),'external'],ImplProc);
@@ -7126,10 +7136,8 @@ begin
 
   if ImplProc.NameParts<>nil then
     begin
-    ProcName:=TProcedureNamePart(ImplProc.NameParts[ImplProc.NameParts.Count-1]).Name;
+    LastNamePart:=TProcedureNamePart(ImplProc.NameParts[ImplProc.NameParts.Count-1]);
-    ImplTemplTypes:=GetProcTemplateTypes(ImplProc);
+    ProcName:=LastNamePart.Name;
-    if ImplTemplTypes<>nil then
-      RaiseNotYetImplemented(20190911105319,ImplProc);
     end
   else
     begin
@@ -7139,7 +7147,6 @@ begin
       if p<1 then break;
       Delete(ProcName,1,p);
     until false;
-    ImplTemplTypes:=nil;
     end;
 
   if ImplProcScope.DeclarationProc=nil then
@@ -12222,11 +12229,6 @@ begin
         NamePart:=TProcedureNamePart(TypeParams[Level-1]);
         if NamePart.Name<>ProcName then
           RaiseNotYetImplemented(20190818122551,El,IntToStr(Level)+': '+NamePart.Name+'<>'+ProcName);
-        if NamePart.Templates<>nil then
-          begin
-          // ToDo: generic method
-          RaiseNotYetImplemented(20190818122619,El);
-          end;
         end;
 
       end
@@ -15959,7 +15961,8 @@ begin
     SpecializeGenericImpl(Result);
 end;
 
-function TPasResolver.InitSpecializeScopes(El: TPasElement): integer;
+procedure TPasResolver.InitSpecializeScopes(El: TPasElement; out
+  State: TScopeStashState);
 
   function PushParentScopes(CurEl: TPasElement): integer;
   var
@@ -16012,6 +16015,7 @@ function TPasResolver.InitSpecializeScopes(El: TPasElement): integer;
         StashScopes(Keep);
         if Keep<>FScopeCount then
           RaiseNotYetImplemented(20190813005130,El);
+        State.ScopeCount:=ScopeCount;
         end;
       if (CurEl.ClassType=TImplementationSection) then
         begin
@@ -16035,7 +16039,8 @@ begin
   {$IFDEF VerboseInitSpecializeScopes}
   writeln('TPasResolver.InitSpecializeScopes START ',GetObjName(El));
   {$ENDIF}
-  Result:=FStashScopeCount;
+  State.ScopeCount:=ScopeCount;
+  State.StashCount:=FStashScopeCount;
   Keep:=PushParentScopes(El.Parent)+1;
   if Keep<FScopeCount then
     begin
@@ -16052,17 +16057,24 @@ begin
   {$ENDIF}
 end;
 
+procedure TPasResolver.RestoreSpecializeScopes(const State: TScopeStashState);
+begin
+  while ScopeCount>State.ScopeCount do
+    PopScope;
+  RestoreStashedScopes(State.StashCount);
+end;
+
 procedure TPasResolver.SpecializeGenericIntf(SpecializedItem: TPRSpecializedItem
   );
 var
   SpecEl, GenericEl: TPasElement;
-  OldStashCount: Integer;
   C: TClass;
   NewRecordType, GenRecordType: TPasRecordType;
   NewClassType, GenClassType: TPasClassType;
   NewArrayType, GenArrayType: TPasArrayType;
   GenProcType, NewProcType: TPasProcedureType;
   GenProc, NewProc: TPasProcedure;
+  OldScopeState: TScopeStashState;
 begin
   if SpecializedItem.Step<>prssNone then
     exit;
@@ -16071,7 +16083,8 @@ begin
   GenericEl:=SpecializedItem.GenericEl;
 
   // change scope
-  OldStashCount:=InitSpecializeScopes(GenericEl);
+  WriteScopesShort('AAA1 TPasResolver.SpecializeGenericIntf *******************');
+  InitSpecializeScopes(GenericEl,OldScopeState);
   {$IFDEF VerbosePasResolver}
   WriteScopesShort('TPasResolver.SpecializeGenericIntf Init SpecEl='+SpecEl.FullName+' GenericEl='+GenericEl.FullName);
   {$ENDIF}
@@ -16117,7 +16130,7 @@ begin
   WriteScopesShort('TPasResolver.SpecializeGenericIntf Finish: '+SpecEl.FullName);
   {$ENDIF}
 
-  RestoreStashedScopes(OldStashCount);
+  RestoreSpecializeScopes(OldScopeState);
   {$IFDEF VerbosePasResolver}
   WriteScopesShort('TPasResolver.SpecializeGenericIntf RestoreStashedScopes: '+SpecEl.FullName);
   {$ENDIF}
@@ -16132,7 +16145,7 @@ var
   SpecializedProcItem: TPRSpecializedProcItem;
   GenImplProc, GenIntfProc, SpecDeclProc: TPasProcedure;
   GenDeclProcScope: TPasProcedureScope;
-  OldStashCount: Integer;
+  OldScopeState: TScopeStashState;
 begin
   // check specialized type step
   if SpecializedItem.Step>prssInterfaceFinished then
@@ -16179,9 +16192,9 @@ begin
         RaiseNotYetImplemented(20190920192731,GenImplProc); // GenScope.GenericStep is wrong
       SpecDeclProc:=SpecializedProcItem.SpecializedProc;
 
-      OldStashCount:=InitSpecializeScopes(GenImplProc);
+      InitSpecializeScopes(GenImplProc,OldScopeState);
       SpecializeGenImplProc(GenIntfProc,SpecDeclProc,SpecializedProcItem);
-      RestoreStashedScopes(OldStashCount);
+      RestoreSpecializeScopes(OldScopeState);
       end;
     end;
 
@@ -16211,10 +16224,11 @@ procedure TPasResolver.SpecializeMembersImpl(GenericType,
   SpecType: TPasMembersType; SpecializedItem: TPRSpecializedTypeItem);
 var
   GenClassOrRec, SpecClassOrRec: TPasMembersType;
-  OldStashCount, i: Integer;
+  i: Integer;
   GenMember, SpecMember, ImplParent: TPasElement;
   GenIntfProc, GenImplProc, SpecIntfProc: TPasProcedure;
   GenIntfProcScope: TPasProcedureScope;
+  OldScopeState: TScopeStashState;
 begin
   GenClassOrRec:=TPasMembersType(GenericType);
   SpecClassOrRec:=TPasMembersType(SpecType);
@@ -16225,7 +16239,7 @@ begin
 
   // specialize member bodies
   ImplParent:=nil;
-  OldStashCount:=FStashScopeCount;
+  OldScopeState:=default(TScopeStashState);
   for i:=0 to GenClassOrRec.Members.Count-1 do
     begin
     GenMember:=TPasElement(GenClassOrRec.Members[i]);
@@ -16247,7 +16261,7 @@ begin
         begin
         // switch scope (e.g. unit implementation section)
         ImplParent:=GenImplProc.Parent;
-        OldStashCount:=InitSpecializeScopes(GenImplProc);
+        InitSpecializeScopes(GenImplProc,OldScopeState);
         {$IFDEF VerbosePasResolver}
         writeln('TPasResolver.SpecializeGenImplProc Specialize implprocs: SpecType=',GetObjName(SpecType),' ImplParent=',GetObjName(ImplParent),' ScopeCount=',ScopeCount,' FStashScopeCount=',FStashScopeCount,' TopScope=',GetObjName(TopScope));
         {$ENDIF}
@@ -16267,7 +16281,7 @@ begin
   if ImplParent<>nil then
     begin
     // restore scope
-    RestoreStashedScopes(OldStashCount);
+    RestoreSpecializeScopes(OldScopeState);
     end;
 end;
 
@@ -16808,8 +16822,7 @@ begin
       RaiseNotYetImplemented(20190920203700,SpecEl);
     if GenProcScope.OverriddenProc<>nil then
       RaiseNotYetImplemented(20190920203536,SpecEl);
-    if GenProcScope.ClassRecScope<>nil then
+    SpecProcScope.ClassRecScope:=GenProcScope.ClassRecScope;
-      RaiseNotYetImplemented(20190920203609,SpecEl);
     if GenProcScope.SelfArg<>nil then
       RaiseNotYetImplemented(20190920203626,SpecEl);
     // SpecProcScope.Flags
@@ -16897,7 +16910,7 @@ begin
     FinishProcedure(SpecEl);
     end
   else if SpecializedItem=nil then
-    // forward or unit-intf declaration
+    // declaration proc, parent is specialized
     FinishProcedure(SpecEl)
   else
     begin

packages/fcl-passrc/src/pastree.pp

@@ -4683,14 +4683,17 @@ procedure TPasProcedure.ForEachCall(const aMethodCall: TOnForEachPasElement;
   const Arg: Pointer);
 var
   i, j: Integer;
+  Templates: TFPList;
 begin
   inherited ForEachCall(aMethodCall, Arg);
   if NameParts<>nil then
     for i:=0 to NameParts.Count-1 do
-      with TProcedureNamePart(NameParts[i]) do
+      begin
-        if Templates<>nil then
+      Templates:=TProcedureNamePart(NameParts[i]).Templates;
-          for j:=0 to Templates.Count-1 do
+      if Templates<>nil then
-            ForEachChildCall(aMethodCall,Arg,TPasElement(Templates[i]),false);
+        for j:=0 to Templates.Count-1 do
+          ForEachChildCall(aMethodCall,Arg,TPasElement(Templates[j]),false);
+      end;
   ForEachChildCall(aMethodCall,Arg,ProcType,false);
   ForEachChildCall(aMethodCall,Arg,PublicName,false);
   ForEachChildCall(aMethodCall,Arg,LibraryExpr,false);

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -143,7 +143,10 @@ type
     // generic methods
     procedure TestGenMethod_VirtualFail;
     procedure TestGenMethod_ClassInterfaceMethodFail;
-    // ToDo: parametrized method mismatch interface method
+    procedure TestGenMethod_ClassConstructorFail;
+    procedure TestGenMethod_TemplNameDifferFail;
+    procedure TestGenMethod_ImplConstraintFail;
+    procedure TestGenMethod_TypeParamCntOverload;
     // ToDo: generic class method overload <T> <S,T>
     // ToDo: generic class method overload <T>(bool) <T>(word)
     // ToDo: procedure TestGenMethod_ClassConstructorFail;
@@ -2042,6 +2045,80 @@ begin
   CheckParserException('generic is not allowed in interface',nParserXNotAllowedInY);
 end;
 
+procedure TTestResolveGenerics.TestGenMethod_ClassConstructorFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    generic class constructor Run<T>(a: T);',
+  '  end;',
+  'generic class constructor TObject.Run<T>(a: T);',
+  'begin end;',
+  'begin',
+  '']);
+  CheckParserException('Expected "Procedure" or "Function" at token "constructor" in file afile.pp at line 4 column 19',
+    nParserExpectToken2Error);
+end;
+
+procedure TTestResolveGenerics.TestGenMethod_TemplNameDifferFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    generic procedure Run<T>(a: T);',
+  '  end;',
+  'generic procedure TObject.Run<S>(a: S);',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException('Declaration of "TObject.Run<S>" differs from previous declaration at afile.pp(4,28)',
+    nDeclOfXDiffersFromPrevAtY);
+end;
+
+procedure TTestResolveGenerics.TestGenMethod_ImplConstraintFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    generic procedure Run<T>(a: T);',
+  '  end;',
+  'generic procedure TObject.Run<T: class>(a: T);',
+  'begin',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException(sImplMustNotRepeatConstraints,nImplMustNotRepeatConstraints);
+end;
+
+procedure TTestResolveGenerics.TestGenMethod_TypeParamCntOverload;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    generic procedure {#A}Run<T>(a: T);',
+  '    generic procedure {#B}Run<M,N>(a: M);',
+  '  end;',
+  'generic procedure TObject.Run<T>(a: T);',
+  'begin',
+  'end;',
+  'generic procedure TObject.Run<M,N>(a: M);',
+  'begin',
+  '  specialize {@A}Run<M>(a);',
+  '  specialize {@B}Run<double,char>(1.3);',
+  'end;',
+  'var obj: TObject;',
+  'begin',
+  '  obj.specialize {@A}Run<word>(3);',
+  '  obj.specialize {@B}Run<word,char>(4);',
+  '']);
+  ParseProgram;
+end;
+
 initialization
   RegisterTests([TTestResolveGenerics]);
 

packages/pastojs/tests/tcgenerics.pas

@@ -24,7 +24,7 @@ type
     Procedure TestGen_ClassAncestor;
     Procedure TestGen_TypeInfo;
     // ToDo: TBird, TBird<T>, TBird<S,T>
-    // ToDo: local const T
+    // ToDo: rename local const T
 
     // generic external class
     procedure TestGen_ExtClass_Array;

utils/pas2js/docs/translation.html

@@ -2762,7 +2762,8 @@ End.
       <li>You can typecast function addresses and function references to JS
       function, e.g. <i>TJSFunction(@SomeProc)</i>, <i>TJSFunction(OnClick)</i>.
       Keep in mind that typecasting a method address creates a function wrapper
-      to bind the Self argument.</li>
+      to bind the Self argument, except when typecasting to <i>TJSFunction</i>
+      (pas2js 1.5+).</li>
     </ul>
     </div>
 
@@ -3009,6 +3010,7 @@ End.
     <li>{$mode delphi} or {$mode objfpc}: Same as -Mdelphi or -Mobjfpc, but only for this unit. You can use units of both modes in a program. If present must be at the top of the unit, or after the module name.</li>
     <li>{$modeswitch externalclass}: allow declaring external classes</li>
     <li>{$modeswitch arrayoperators}: allow + operator to concatenate arrays, default in mode delphi</li>
+    <li>{$modeswitch OmitRTTI}: treat published sections as public</li>
     <li>{$macro on|off} enables macro replacements. Only macros with a value are replaced. Macros are never replaced inside directives.</li>
     <li>{$I filename} or {$include filename} - insert include file</li>
     <li>{$I %param%}:
@@ -3072,6 +3074,8 @@ End.
         <li>Check type casts, e.g. <i>TBird(AnObject)</i> becomes <i>AnObject as TBird</i></li>
       </ul>
     </li>
+    <li>{$DispatchField Msg}: enable checking <i>message number</i> methods for record field name "Msg"</li>
+    <li>{$DispatchStrField MsgStr}: enable checking <i>message string</i> methods for record field name "Msg"</li>
     </ul>
     Defines:
     <ul>