fcl-passrc: specialize type reference

git-svn-id: trunk@42663 -

packages/fcl-passrc/src/pasresolver.pp

@@ -5625,7 +5625,7 @@ var
   aType: TPasType;
 begin
   {$IFDEF VerbosePasResolver}
-  writeln('TPasResolver.FinishTypeDef El=',GetObjName(El));
+  //writeln('TPasResolver.FinishTypeDef El=',GetObjName(El));
   {$ENDIF}
   C:=El.ClassType;
   if C=TPasEnumType then
@@ -6285,6 +6285,9 @@ var
   DestType: TPasType;
   i: Integer;
 begin
+  {$IFDEF VerbosePasResolver}
+  //writeln('TPasResolver.FinishSpecializeType ');
+  {$ENDIF}
   // resolve Params
   Params:=El.Params;
   for i:=0 to Params.Count-1 do
@@ -11164,6 +11167,7 @@ var
   i: Integer;
   Scope: TPasScope;
   Old: TPasIdentifier;
+  ClassOrRec: TPasMembersType;
 begin
   {$IFDEF VerbosePasResolver}
   writeln('TPasResolver.AddEnumValue ',GetObjName(El));
@@ -11189,6 +11193,9 @@ begin
       Old:=TPasIdentifierScope(Scope).FindIdentifier(El.Name);
       if Old=nil then
         TPasIdentifierScope(Scope).AddIdentifier(El.Name,El,pikSimple);
+      ClassOrRec:=Scope.Element as TPasMembersType;
+      if GetTypeParameterCount(ClassOrRec)>0 then
+        break; // enums in generics do not propagate
       end
     else if (Scope is TPasProcedureScope) or (Scope is TPasSectionScope) then
       begin
@@ -14435,6 +14442,9 @@ begin
     if ParamType is TPasGenericTemplateType then
       begin
       // not fully specialized
+      {$IFDEF VerbosePasResolver}
+      writeln('TPasResolver.CheckSpecializeConstraints ',GetObjName(El),' i=',i,' P=',GetObjName(P),' ParamType=',GetObjName(ParamType));
+      {$ENDIF}
       Result:=false;
       // ToDo: check if both constraints fit
       continue;
@@ -14502,7 +14512,12 @@ begin
       begin
       if (ParentEl is TPasGenericType)
           and (GetTypeParameterCount(TPasGenericType(ParentEl))>0) then
+        begin
+        {$IFDEF VerbosePasResolver}
+        //writeln('TPasResolver.CheckSpecializeConstraints El=',GetObjName(El),' not specialized Parent=',GetObjName(ParentEl));
+        {$ENDIF}
         exit(false); // parent is not specialized
+        end;
       ParentEl:=ParentEl.Parent;
       end;
     end;
@@ -15064,17 +15079,12 @@ begin
   if GenElType.Parent<>GenEl then
     begin
     // reference
-    if GenElType is TPasGenericTemplateType then
-      begin
-      Ref:=FindElement(GenElType.Name);
-      if (Ref<>GenElType) and (Ref is TPasType) then
-        begin
-        // replace template with specialized type
-        GenElType:=TPasType(Ref);
-        end;
-      end;
+    Ref:=FindElement(GenElType.Name);
+    if not (Ref is TPasType) then
+      RaiseNotYetImplemented(20190812021538,GenEl,GetObjName(Ref));
+    GenElType:=TPasType(Ref);
     if SpecElType<>nil then
-      SpecElType.Release{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF};
+      RaiseNotYetImplemented(20190812021617,GenEl);
     SpecElType:=GenElType;
     SpecElType.AddRef{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF};
     exit;
@@ -15137,7 +15147,7 @@ procedure TPasResolver.SpecializeElList(GenEl, SpecEl: TPasElement;
   {$IFDEF CheckPasTreeRefCount}; const RefId: string{$ENDIF});
 var
   i: Integer;
-  GenListItem, SpecListItem: TPasElement;
+  GenListItem, SpecListItem, Ref: TPasElement;
   NewClass: TPTreeElement;
 begin
   for i:=0 to GenList.Count-1 do
@@ -15147,9 +15157,14 @@ begin
       begin
       if not AllowReferences then
         RaiseNotYetImplemented(20190808212421,GenEl,IntToStr(i));
+      if not (GenListItem is TPasType) then
+        RaiseNotYetImplemented(20190812025715,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem));
       // reference
-      GenListItem.AddRef{$IFDEF CheckPasTreeRefCount}(RefID){$ENDIF};
-      SpecList.Add(GenListItem);
+      Ref:=FindElement(GenListItem.Name);
+      if not (Ref is TPasType) then
+        RaiseNotYetImplemented(20190812025715,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem)+' Ref='+GetObjName(Ref));
+      Ref.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
+      SpecList.Add(Ref);
       continue;
       end;
     NewClass:=TPTreeElement(GenListItem.ClassType);
@@ -15308,13 +15323,30 @@ end;
 
 procedure TPasResolver.SpecializeSpecializeType(GenEl,
   SpecEl: TPasSpecializeType);
+var
+  GenDestType: TPasType;
+  Ref: TPasElement;
 begin
-  SpecializeElType(GenEl,SpecEl,GenEl.DestType,SpecEl.DestType);
+  // search DestType<ParamCount>
+  GenDestType:=GenEl.DestType;
+  if GenDestType=nil then
+    RaiseNotYetImplemented(20190812022211,GenEl);
+  if GenDestType.Parent=GenEl then
+    RaiseNotYetImplemented(20190812022251,GenEl);
+  Ref:=FindElementFor(GenDestType.Name,GenEl.Parent,GenEl.Params.Count);
+  if not (Ref is TPasGenericType) then
+    RaiseNotYetImplemented(20190812022359,GenEl,GetObjName(Ref));
+  SpecEl.DestType:=TPasGenericType(Ref);
+  SpecEl.DestType.AddRef{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF};
+
   SpecializeElExpr(GenEl,SpecEl,GenEl.Expr,SpecEl.Expr);
   SpecializeElList(GenEl,SpecEl,GenEl.Params,SpecEl.Params,true
     {$IFDEF CheckPasTreeRefCount},'TPasSpecializeType.Params'{$ENDIF});
 
   FinishSpecializeType(SpecEl);
+  {$IFDEF VerbosePasResolver}
+  //writeln('TPasResolver.SpecializeSpecializeType ',GetObjName(SpecEl.DestType),' ',GetObjName(SpecEl.CustomData));
+  {$ENDIF}
 end;
 
 procedure TPasResolver.SpecializeArgument(GenEl, SpecEl: TPasArgument);
@@ -20528,7 +20560,7 @@ begin
   for i:=0 to ProcArgs1.Count-1 do
     begin
     {$IFDEF VerbosePasResolver}
-    writeln('TPasResolver.CheckProcAssignCompatibility ',i,'/',ProcArgs1.Count);
+    writeln('TPasResolver.CheckProcTypeCompatibility ',i,'/',ProcArgs1.Count);
     {$ENDIF}
     ExpectedArg:=TPasArgument(ProcArgs1[i]);
     ActualArg:=TPasArgument(ProcArgs2[i]);

packages/fcl-passrc/src/pparser.pp

@@ -1525,10 +1525,17 @@ Var
   K : TSimpleTypeKind;
   Name : String;
   Expr: TPasExpr;
-  ok: Boolean;
+  ok, MustBeSpecialize: Boolean;
 
 begin
   Result:=nil;
+  if CurToken=tkspecialize then
+    begin
+    MustBeSpecialize:=true;
+    ExpectIdentifier;
+    end
+  else
+    MustBeSpecialize:=false;
   Name := CurTokenString;
   Expr:=nil;
   Ref:=nil;
@@ -1547,6 +1554,9 @@ begin
         end;
       end;
 
+    if MustBeSpecialize and (CurToken<>tkLessThan) then
+      ParseExcTokenError('<');
+
     // Current token is first token after identifier.
     if IsFull and (CurToken=tkSemicolon) or isCurTokenHint then // Type A = B;
       begin
@@ -1719,8 +1729,7 @@ begin
       ParseExcTokenError('[20190801113005]');
     // ToDo: cascaded specialize A<B>.C<D>
 
-    if TypeName='' then
-      Engine.FinishScope(stTypeDef,ST);
+    Engine.FinishScope(stTypeDef,ST);
     Result:=ST;
   finally
     if Result=nil then
@@ -1841,10 +1850,7 @@ begin
       tkInterface:
         Result := ParseClassDecl(Parent, NamePos, TypeName, okInterface,PM);
       tkSpecialize:
-        begin
-        NextToken;
         Result:=ParseSimpleType(Parent,CurSourcePos,TypeName);
-        end;
       tkClass:
         begin
         isHelper:=false;
@@ -2096,7 +2102,7 @@ begin
       {AllowWriteln}
       if po_resolvestandardtypes in FOptions then
         begin
-        writeln('ERROR: TPasParser.ParseSimpleType resolver failed to raise an error');
+        writeln('ERROR: TPasParser.ResolveTypeReference: resolver failed to raise an error');
         ParseExcExpectedIdentifier;
         end;
       {AllowWriteln-}
@@ -3520,33 +3526,33 @@ begin
             // Scanner.SetForceCaret(OldForceCaret); // It may have been switched off
             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
+              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
+                // Remove previous forward declarations, if necessary
+                for i := 0 to Declarations.Classes.Count - 1 do
                 begin
-                  // Remove previous forward declarations, if necessary
-                  for i := 0 to Declarations.Classes.Count - 1 do
+                  ClassEl := TPasClassType(Declarations.Classes[i]);
+                  if CompareText(ClassEl.Name, TypeEl.Name) = 0 then
                   begin
-                    ClassEl := TPasClassType(Declarations.Classes[i]);
-                    if CompareText(ClassEl.Name, TypeEl.Name) = 0 then
-                    begin
-                      Declarations.Classes.Delete(i);
-                      for j := 0 to Declarations.Declarations.Count - 1 do
-                        if CompareText(TypeEl.Name,
-                          TPasElement(Declarations.Declarations[j]).Name) = 0 then
-                        begin
-                          Declarations.Declarations.Delete(j);
-                          break;
-                        end;
-                      ClassEl.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
-                      break;
-                    end;
+                    Declarations.Classes.Delete(i);
+                    for j := 0 to Declarations.Declarations.Count - 1 do
+                      if CompareText(TypeEl.Name,
+                        TPasElement(Declarations.Declarations[j]).Name) = 0 then
+                      begin
+                        Declarations.Declarations.Delete(j);
+                        break;
+                      end;
+                    ClassEl.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
+                    break;
                   end;
-                  // Add the new class to the class list
-                  Declarations.Classes.Add(TypeEl)
-                end else
-                  Declarations.Types.Add(TypeEl);
+                end;
+                // Add the new class to the class list
+                Declarations.Classes.Add(TypeEl)
+              end else
+                Declarations.Types.Add(TypeEl);
               end;
             end;
           declExports:

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -38,7 +38,6 @@ type
     procedure TestGen_RecordDelphi;
     procedure TestGen_RecordNestedSpecialized;
     procedure TestGen_Record_SpecializeSelfInsideFail;
-    // ToDo: enums within generic
     procedure TestGen_RecordAnoArray;
     // ToDo: procedure TestGen_SpecializeArg_ArrayOf;  type TBird = specialize<array of word>
     // ToDo: unitname.specialize TBird<word>.specialize
@@ -57,6 +56,9 @@ type
     // 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
+    procedure TestGen_NestedType;
+    // ToDo: procedure TestGen_NestedDottedType;
+    procedure TestGen_Class_Enums_NotPropagating;
 
     // generic external class
     procedure TestGen_ExtClass_Array;
@@ -78,15 +80,12 @@ type
     // generic statements
     procedure TestGen_LocalVar;
     procedure TestGen_Statements;
-    procedure TestGen_ForLoop;
     // ToDo: for-in
-    // ToDo: if
-    // ToDo: case
-    // ToDo: while, repeat
     // ToDo: try finally/except
     // ToDo: call
     // ToDo: dot
     // ToDo: is as
+    // ToDo: typecast
   end;
 
 implementation
@@ -410,7 +409,7 @@ begin
   '    r: TRec;',
   '  end;',
   'var',
-  '  s: specialize TRec;',
+  '  s: TRec;',
   '  {=Typ}w: T;',
   'begin',
   '  s.b.v:=w;',
@@ -502,6 +501,46 @@ begin
   CheckResolverException('type "TBird" is not yet completely defined',nTypeXIsNotYetCompletelyDefined);
 end;
 
+procedure TTestResolveGenerics.TestGen_NestedType;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  TObject = class end;',
+  '  generic TBird<T> = class',
+  '  public type',
+  '    TArrayEvent = reference to procedure(El: T);',
+  '  public',
+  '    p: TArrayEvent;',
+  '  end;',
+  '  TBirdWord = specialize TBird<word>;',
+  'var',
+  '  b: TBirdWord;',
+  'begin',
+  '  b.p:=procedure(El: word) begin end;']);
+  ParseProgram;
+end;
+
+procedure TTestResolveGenerics.TestGen_Class_Enums_NotPropagating;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  TObject = class end;',
+  '  generic TBird<T> = class',
+  '  public type',
+  '    TEnum = (red, blue);',
+  '  const',
+  '    e = blue;',
+  '  end;',
+  'const',
+  '  r = red;',
+  'begin']);
+  CheckResolverException('identifier not found "red"',nIdentifierNotFound);
+end;
+
 procedure TTestResolveGenerics.TestGen_ExtClass_Array;
 begin
   StartProgram(false);
@@ -516,11 +555,14 @@ begin
   '    procedure SetElements(Index: NativeInt; const AValue: T); external name ''[]'';',
   '  public',
   '    type TSelfType = TJSGenArray<T>;',
+  '    TArrayEvent = reference to function(El: T; Arr: TSelfType): Boolean;',
+  '    TArrayCallback = TArrayEvent;',
   '  public',
   '    FLength : NativeInt; external name ''length'';',
   '    constructor new; overload;',
   '    constructor new(aLength : NativeInt); overload;',
   '    class function _of() : TSelfType; varargs; external name ''of'';',
+  '    function every(const aCallback: TArrayCallBack): boolean; overload;',
   '    function fill(aValue : T) : TSelfType; overload;',
   '    function fill(aValue : T; aStartIndex : NativeInt) : TSelfType; overload;',
   '    function fill(aValue : T; aStartIndex,aEndIndex : NativeInt) : TSelfType; overload;',
@@ -541,6 +583,10 @@ begin
   '  wa.length:=10;',
   '  wa[11]:=w;',
   '  w:=wa[12];',
+  '  wa.every(function(El: word; Arr: TJSWordArray): Boolean',
+  '           begin',
+  '           end',
+  '      );',
   '']);
   ParseProgram;
 end;
@@ -627,29 +673,6 @@ begin
   ParseProgram;
 end;
 
-procedure TTestResolveGenerics.TestGen_ForLoop;
-begin
-  StartProgram(false);
-  Add([
-  '{$mode objfpc}',
-  'type',
-  '  TObject = class end;',
-  '  generic TBird<{#Templ}T> = class',
-  '    function Fly(p:T): T;',
-  '  end;',
-  'function TBird.Fly(p:T): T;',
-  'var i: T;',
-  'begin',
-  '  for i:=0 to 3 do Result:=i+p;',
-  'end;',
-  'var',
-  '  b: specialize TBird<word>;',
-  'begin',
-  '  b.Fly(2);',
-  '']);
-  ParseProgram;
-end;
-
 initialization
   RegisterTests([TTestResolveGenerics]);