fcl-passrc: parser: allow ^dottedidentifier, forbid ^simpletype

git-svn-id: trunk@42759 -

packages/fcl-passrc/src/pasresolver.pp

@@ -15449,7 +15449,7 @@ begin
   else if (C=TPasImplTryFinally)
       or (C=TPasImplTryExcept)
       or (C=TPasImplTryExceptElse) then
-    SpecializeImplBlock(TPasImplCaseElse(GenEl),TPasImplCaseElse(SpecEl))
+    SpecializeImplBlock(TPasImplTryHandler(GenEl),TPasImplTryHandler(SpecEl))
   else if C=TPasImplExceptOn then
     begin
     AddExceptOn(TPasImplExceptOn(SpecEl));

packages/fcl-passrc/src/pparser.pp

@@ -1741,11 +1741,27 @@ function TPasParser.ParsePointerType(Parent: TPasElement;
 
 var
   ok: Boolean;
+  Name: String;
 begin
   Result := TPasPointerType(CreateElement(TPasPointerType, TypeName, Parent, NamePos));
   ok:=false;
   Try
-    TPasPointerType(Result).DestType := ParseType(Result,CurSourcePos);
+    // only allowed: ^dottedidentifer
+    // forbidden: ^^identifier, ^array of word, ^A<B>
+    ExpectIdentifier;
+    Name:=CurTokenString;
+    repeat
+      NextToken;
+      if CurToken=tkDot then
+        begin
+        ExpectIdentifier;
+        Name := Name+'.'+CurTokenString;
+        end
+      else
+        break;
+    until false;
+    UngetToken;
+    Result.DestType:=ResolveTypeReference(Name,Result);
     Engine.FinishScope(stTypeDef,Result);
     ok:=true;
   finally

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -55,17 +55,16 @@ type
     procedure TestGen_ClassForwardConstraintTypeMismatch;
     procedure TestGen_ClassForward_Circle;
     procedure TestGen_Class_RedeclareInUnitImplFail;
-    // ToDo: add another in unit implementation
+    procedure TestGen_Class_AnotherInUnitImpl;
     procedure TestGen_Class_Method;
-    // ToDo: procedure TestGen_Class_MethodOverride;
+    procedure TestGen_Class_MethodOverride;
     procedure TestGen_Class_MethodDelphi;
     // ToDo: procedure TestGen_Class_MethodDelphiTypeParamMissing;
     // ToDo: procedure TestGen_Class_MethodImplConstraintFail;
     procedure TestGen_Class_SpecializeSelfInside;
-    // ToDo: generic class overload <T> <S,T>
     procedure TestGen_Class_GenAncestor;
     procedure TestGen_Class_AncestorSelfFail;
-    // ToDo: class of TBird<word> fail
+    procedure TestGen_ClassOfSpecializeFail;
     // ToDo: UnitA.impl uses UnitB.intf uses UnitA.intf, UnitB has specialize of UnitA
     procedure TestGen_Class_NestedType;
     procedure TestGen_Class_NestedRecord;
@@ -82,12 +81,13 @@ type
 
     // generic array
     procedure TestGen_Array;
+    // ToDo: anonymous array type
 
     // generic procedure type
     procedure TestGen_ProcType;
 
-    // ToDo: pointer of generic
-    // ToDo: PBird = ^TBird<word> fail
+    // pointer of generic
+    procedure TestGen_PointerDirectSpecializeFail;
 
     // ToDo: helpers for generics
 
@@ -632,6 +632,20 @@ begin
     nDuplicateIdentifier);
 end;
 
+procedure TTestResolveGenerics.TestGen_Class_AnotherInUnitImpl;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'type',
+  '  TObject = class end;',
+  '  generic TBird<T> = class v: T; end;',
+  'implementation',
+  'type generic TBird<T,U> = record x: T; y: U; end;',
+  '']);
+  ParseUnit;
+end;
+
 procedure TTestResolveGenerics.TestGen_Class_Method;
 begin
   StartProgram(false);
@@ -657,6 +671,31 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGen_Class_MethodOverride;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  TObject = class end;',
+  '  generic TBird<T> = class',
+  '    function Fly(p:T): T; virtual; abstract;',
+  '  end;',
+  '  generic TEagle<S> = class(specialize TBird<S>)',
+  '    function Fly(p:S): S; override;',
+  '  end;',
+  'function TEagle.Fly(p:S): S;',
+  'begin',
+  'end;',
+  'var',
+  '  e: specialize TEagle<word>;',
+  '  w: word;',
+  'begin',
+  '  w:=e.Fly(w);',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolveGenerics.TestGen_Class_MethodDelphi;
 begin
   StartProgram(false);
@@ -741,6 +780,22 @@ begin
   CheckResolverException('type "TBird<>" is not yet completely defined',nTypeXIsNotYetCompletelyDefined);
 end;
 
+procedure TTestResolveGenerics.TestGen_ClassOfSpecializeFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode objfpc}',
+  'type',
+  '  TObject = class end;',
+  '  generic TBird<T> = class',
+  '    e: T;',
+  '  end;',
+  '  TBirdClass = class of specialize TBird<word>;',
+  'begin',
+  '']);
+  CheckParserException('Expected "Identifier" at token "specialize" in file afile.pp at line 8 column 25',nParserExpectTokenError);
+end;
+
 procedure TTestResolveGenerics.TestGen_Class_NestedType;
 begin
   StartProgram(false);
@@ -1020,6 +1075,18 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGen_PointerDirectSpecializeFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  generic TRec<T> = record v: T; end;',
+  '  PRec = ^specialize TRec<word>;',
+  'begin',
+  '']);
+  CheckParserException('Expected "Identifier" at token "specialize" in file afile.pp at line 4 column 11',nParserExpectTokenError);
+end;
+
 procedure TTestResolveGenerics.TestGen_GenericFunction;
 begin
   exit;

packages/fcl-passrc/tests/tcresolver.pas

@@ -15929,8 +15929,8 @@ begin
   Add([
   'type p = ^(red, green);',
   'begin']);
-  CheckResolverException('not yet implemented: pointer of anonymous type',
-    nNotYetImplemented);
+  CheckParserException('Expected "Identifier" at token "(" in file afile.pp at line 2 column 11',
+    nParserExpectTokenError);
 end;
 
 procedure TTestResolver.TestPointer_AssignPointerToClassFail;