fcl-passrc: useanalyzer: specializetype

git-svn-id: trunk@42523 -

packages/fcl-passrc/src/pasresolveeval.pas

@@ -194,6 +194,7 @@ const
   nConstraintXAndConstraintYCannotBeTogether = 3128;
   nXIsNotAValidConstraint = 3129;
   nWrongNumberOfParametersForGenericType = 3130;
+  nGenericsWithoutSpecializationAsType = 3131;
 
   // using same IDs as FPC
   nVirtualMethodXHasLowerVisibility = 3250; // was 3050
@@ -335,6 +336,7 @@ resourcestring
   sConstraintXAndConstraintYCannotBeTogether = '''%s'' constraint and ''%s'' constraint cannot be specified together';
   sXIsNotAValidConstraint = '''%s'' is not a valid constraint';
   sWrongNumberOfParametersForGenericType = 'wrong number of parameters for generic type %s';
+  sGenericsWithoutSpecializationAsType = 'Generics without specialization cannot be used as a type for a %s';
 
 type
   { TResolveData - base class for data stored in TPasElement.CustomData }

packages/fcl-passrc/src/pasresolver.pp

@@ -14110,6 +14110,7 @@ var
   OldStashCount, i: Integer;
   Scope: TPasGenericScope;
   TemplType: TPasGenericTemplateType;
+  NewParent: TPasElement;
 begin
   Result:=nil;
   GenericType:=El.DestType as TPasGenericType;
@@ -14134,9 +14135,23 @@ begin
     SpecializedTypes.Add(Result);
     NewName:=GenericType.Name+'$G'+IntToStr(SpecializedTypes.Count);
     NewClass:=TPTreeElement(GenericType.ClassType);
-    NewEl:=TPasGenericType(NewClass.Create(NewName,GenericType.Parent));
-    Result.SpecializedType:=NewEl;
-    NewEl.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
+    NewParent:=GenericType.Parent;
+    NewEl:=TPasGenericType(NewClass.Create(NewName,NewParent));
+    Result.SpecializedType:=NewEl; // this calls AddRef
+
+    if NewParent is TPasDeclarations then
+      begin
+      TPasDeclarations(NewParent).Declarations.Add(NewEl);
+      {$IFDEF CheckPasTreeRefCount}NewEl.RefIds.Add('TPasDeclarations.Children');{$ENDIF}
+      end
+    else if NewParent is TPasMembersType then
+      begin
+      TPasMembersType(NewParent).Members.Add(NewEl);
+      {$IFDEF CheckPasTreeRefCount}NewEl.RefIds.Add('TPasMembersType.Members');{$ENDIF}
+      end
+    else
+      NewEl.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF}; // fix refcount
+
     SpecializePasElementProperties(GenericType,NewEl);
 
     // create scope of specialized type
@@ -14202,6 +14217,8 @@ function TPasResolver.InitSpecializeScopes(El: TPasElement): integer;
       begin
       if CurEl.Parent=nil then
         RaiseInternalError(20190728130238,GetObjName(CurEl));
+      if CurEl.CustomData=nil then
+        exit(PushParentScopes(CurEl.Parent));
       if not (CurEl.CustomData is TPasIdentifierScope) then
         RaiseNotYetImplemented(20190728131934,El,GetObjName(CurEl)+' '+GetObjName(CurEl.CustomData));
       Keep:=PushParentScopes(CurEl.Parent);
@@ -22951,9 +22968,18 @@ procedure TPasResolver.CheckUseAsType(aType: TPasElement; id: TMaxPrecInt;
   ErrorEl: TPasElement);
 begin
   if aType=nil then exit;
-  if aType.ClassType<>TPasClassType then exit;
-  if TPasClassType(aType).HelperForType<>nil then
-    RaiseHelpersCannotBeUsedAsType(id,ErrorEl);
+  if aType is TPasGenericType then
+    begin
+    if aType.ClassType=TPasClassType then
+      begin
+      if TPasClassType(aType).HelperForType<>nil then
+        RaiseHelpersCannotBeUsedAsType(id,ErrorEl);
+      end;
+    if (TPasGenericType(aType).GenericTemplateTypes<>nil)
+        and (TPasGenericType(aType).GenericTemplateTypes.Count>0) then
+          RaiseMsg(id,nGenericsWithoutSpecializationAsType,sGenericsWithoutSpecializationAsType,
+            [ErrorEl.ElementTypeName],ErrorEl);
+    end;
 end;
 
 function TPasResolver.GetPasClassAncestor(ClassEl: TPasClassType;

packages/fcl-passrc/src/pastree.pp

@@ -3045,7 +3045,7 @@ begin
     begin
     Child:=TPasElement(Declarations[i]);
     Child.Parent:=nil;
-    Child.Release{$IFDEF CheckPasTreeRefCount}('TPasDeclarations.Childs'){$ENDIF};
+    Child.Release{$IFDEF CheckPasTreeRefCount}('TPasDeclarations.Children'){$ENDIF};
     end;
   FreeAndNil(Declarations);
 

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -270,6 +270,7 @@ type
     procedure UseType(El: TPasType; Mode: TPAUseMode); virtual;
     procedure UseClassOrRecType(El: TPasMembersType; Mode: TPAUseMode); virtual;
     procedure UseClassConstructor(El: TPasMembersType); virtual;
+    procedure UseSpecializeType(El: TPasSpecializeType; Mode: TPAUseMode); virtual;
     procedure UseVariable(El: TPasVariable; Access: TResolvedRefAccess;
       UseFull: boolean); virtual;
     procedure UseResourcestring(El: TPasResString); virtual;
@@ -1924,6 +1925,8 @@ begin
       end
     else if C.InheritsFrom(TPasProcedureType) then
       UseProcedureType(TPasProcedureType(El))
+    else if C=TPasSpecializeType then
+      UseSpecializeType(TPasSpecializeType(El),Mode)
     else
       RaiseNotSupported(20170306170315,El);
 
@@ -2200,6 +2203,24 @@ begin
     end;
 end;
 
+procedure TPasAnalyzer.UseSpecializeType(El: TPasSpecializeType;
+  Mode: TPAUseMode);
+var
+  Param: TPasElement;
+  i: Integer;
+begin
+  if not MarkElementAsUsed(El) then exit;
+  // El.DestType is TPasGenericType, which is never be used
+  if El.CustomData is TPasSpecializeTypeData then
+    UseElType(El,TPasSpecializeTypeData(El.CustomData).SpecializedType,Mode);
+  for i:=0 to El.Params.Count-1 do
+    begin
+    Param:=TPasElement(El.Params[i]);
+    if Param is TPasGenericTemplateType then continue;
+    UseElement(Param,rraRead,false);
+    end;
+end;
+
 procedure TPasAnalyzer.UseVariable(El: TPasVariable;
   Access: TResolvedRefAccess; UseFull: boolean);
 var

packages/fcl-passrc/src/pparser.pp

@@ -3358,6 +3358,7 @@ var
   procedure InitGenericType(NewEl: TPasGenericType; GenericTemplateTypes: TFPList);
   begin
     Declarations.Declarations.Add(NewEl);
+    {$IFDEF CheckPasTreeRefCount}NewEl.ChangeRefId('CreateElement','TPasDeclarations.Children');{$ENDIF}
     NewEl.SetGenericTemplates(GenericTemplateTypes);
     Engine.FinishScope(stGenericTypeTemplates,NewEl);
   end;
@@ -3504,6 +3505,7 @@ begin
             if Assigned(TypeEl) then        // !!!
               begin
                 Declarations.Declarations.Add(TypeEl);
+                {$IFDEF CheckPasTreeRefCount}if TypeEl.RefIds.IndexOf('CreateElement')>=0 then TypeEl.ChangeRefId('CreateElement','TPasDeclarations.Children');{$ENDIF}
                 if (TypeEl.ClassType = TPasClassType)
                     and (not (po_keepclassforward in Options)) then
                 begin
@@ -3548,6 +3550,7 @@ begin
               begin
                 ExpEl := TPasExportSymbol(List[i]);
                 Declarations.Declarations.Add(ExpEl);
+                {$IFDEF CheckPasTreeRefCount}ExpEl.ChangeRefId('CreateElement','TPasDeclarations.Children');{$ENDIF}
                 Declarations.ExportSymbols.Add(ExpEl);
               end;
             finally
@@ -3578,6 +3581,7 @@ begin
             begin
             PropEl:=ParseProperty(Declarations,CurtokenString,visDefault,false);
             Declarations.Declarations.Add(PropEl);
+            {$IFDEF CheckPasTreeRefCount}PropEl.ChangeRefId('CreateElement','TPasDeclarations.Children');{$ENDIF}
             Declarations.Properties.Add(PropEl);
             Engine.FinishScope(stDeclaration,PropEl);
             end;
@@ -3911,10 +3915,8 @@ end;
 
 // Starts after the variable name
 function TPasParser.ParseConstDecl(Parent: TPasElement): TPasConst;
-
 var
   OldForceCaret,ok: Boolean;
-
 begin
   SaveComments;
   Result := TPasConst(CreateElement(TPasConst, CurTokenString, Parent));
@@ -3930,6 +3932,7 @@ begin
       OldForceCaret:=Scanner.SetForceCaret(True);
       try
         Result.VarType := ParseType(Result,CurSourcePos);
+        {$IFDEF CheckPasTreeRefCount}if Result.VarType.RefIds.IndexOf('CreateElement')>=0 then Result.VarType.ChangeRefId('CreateElement','TPasVariable.VarType'){$ENDIF};
       finally
         Scanner.SetForceCaret(OldForceCaret);
       end;
@@ -4506,6 +4509,7 @@ begin
     OldForceCaret:=Scanner.SetForceCaret(True);
     try
       VarType := ParseComplexType(VarEl);
+      {$IFDEF CheckPasTreeRefCount}if VarType.RefIds.IndexOf('CreateElement')>=0 then VarType.ChangeRefId('CreateElement','TPasVariable.VarType'){$ENDIF};
     finally
       Scanner.SetForceCaret(OldForceCaret);
     end;
@@ -5432,6 +5436,7 @@ begin
     if CurToken = tkColon then
       begin
       Result.VarType := ParseType(Result,CurSourcePos);
+      {$IFDEF CheckPasTreeRefCount}if Result.VarType.RefIds.IndexOf('CreateElement')>=0 then Result.VarType.ChangeRefId('CreateElement','TPasVariable.VarType'){$ENDIF};
       NextToken;
       end
     else if not IsClass then

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -13,8 +13,12 @@ type
 
   TTestResolveGenerics = Class(TCustomTestResolver)
   Published
+    // generic functions
     procedure TestGen_GenericFunction; // ToDo
+
+    // generic types
     procedure TestGen_MissingTemplateFail;
+    procedure TestGen_VarTypeWithoutSpecializeFail;
     procedure TestGen_ConstraintStringFail;
     procedure TestGen_ConstraintMultiClassFail;
     procedure TestGen_ConstraintRecordExpectedFail;
@@ -31,10 +35,13 @@ type
     // ToDo: generic class
     // ToDo: generic class forward
     // ToDo: ancestor cycle: TBird<T> = class(TBird<word>) fail
+    // ToDo: class-of
     // ToDo: UnitA.impl uses UnitB.intf uses UnitA.intf, UnitB has specialize of UnitA
     // ToDo: generic interface
     // ToDo: generic array
     // ToDo: generic procedure type
+    // ToDo: pointer of generic
+    // ToDo: generic helpers
   end;
 
 implementation
@@ -68,6 +75,18 @@ begin
   CheckParserException('Expected "Identifier"',nParserExpectTokenError);
 end;
 
+procedure TTestResolveGenerics.TestGen_VarTypeWithoutSpecializeFail;
+begin
+  StartProgram(false);
+  Add([
+  'type generic TBird<T> = record end;',
+  'var b: TBird;',
+  'begin',
+  '']);
+  CheckResolverException('Generics without specialization cannot be used as a type for a variable',
+    nGenericsWithoutSpecializationAsType);
+end;
+
 procedure TTestResolveGenerics.TestGen_ConstraintStringFail;
 begin
   StartProgram(false);

packages/fcl-passrc/tests/tcuseanalyzer.pas

@@ -67,6 +67,7 @@ type
     procedure TestM_Const;
     procedure TestM_ResourceString;
     procedure TestM_Record;
+    procedure TestM_RecordGeneric;
     procedure TestM_PointerTyped_Record;
     procedure TestM_Array;
     procedure TestM_NestedFuncResult;
@@ -880,6 +881,34 @@ begin
   AnalyzeProgram;
 end;
 
+procedure TTestUseAnalyzer.TestM_RecordGeneric;
+begin
+  StartProgram(false);
+  Add([
+  'procedure {#DoIt_used}DoIt;',
+  'type',
+  '  {#integer_used}integer = longint;',
+  '  {#number_used}number = word;',
+  '  generic {#trec_used}TRec<{#trec_t_notused}T> = record',
+  '    {#a_used}a: integer;',
+  '    {#b_notused}b: integer;',
+  '    {#c_used}c: T;',
+  '  end;',
+  'var',
+  '  {#r_used}r: specialize TRec<number>;',
+  'const',
+  '  ci = 2;',
+  '  cr: specialize TRec<number> = (a:0;b:ci;c:2);',
+  'begin',
+  '  r.a:=3;',
+  '  with r do c:=4;',
+  '  r:=cr;',
+  'end;',
+  'begin',
+  '  DoIt;']);
+  AnalyzeProgram;
+end;
+
 procedure TTestUseAnalyzer.TestM_PointerTyped_Record;
 begin
   StartProgram(false);