fcl-passrc: resolver: type alias type

git-svn-id: trunk@38851 -

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -826,7 +826,7 @@ begin
       begin
       Member:=TPasArrayType(El).Ranges[i];
       Resolver.ComputeElement(Member,MemberResolved,[rcConstant]);
-      UseSubEl(MemberResolved.TypeEl);
+      UseSubEl(MemberResolved.HiTypeEl);
       end;
     end
   else if C=TPasPointerType then
@@ -1315,7 +1315,7 @@ begin
     pekArrayParams:
       begin
       Resolver.ComputeElement(Params.Value,ValueResolved,[]);
-      if not Resolver.IsDynArray(ValueResolved.TypeEl) then
+      if not Resolver.IsDynArray(ValueResolved.LoTypeEl) then
         UseExprRef(El,Params.Value,Access,UseFull);
       end;
     pekSet: ;

packages/fcl-passrc/src/pparser.pp

@@ -192,6 +192,7 @@ type
       UseParentAsResultParent: Boolean; const ASrcPos: TPasSourcePos): TPasFunctionType;
     function FindElement(const AName: String): TPasElement; virtual; abstract;
     procedure FinishScope(ScopeType: TPasScopeType; El: TPasElement); virtual;
+    procedure FinishTypeAlias(var aType: TPasType); virtual;
     function FindModule(const AName: String): TPasModule; virtual;
     function FindModule(const AName: String; NameExpr, InFileExpr: TPasExpr): TPasModule; virtual;
     function CheckPendingUsedInterface(Section: TPasSection): boolean; virtual; // true if changed
@@ -376,7 +377,7 @@ type
     function ParseProcedureType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String; const PT: TProcType): TPasProcedureType;
     function ParseStringType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String): TPasAliasType;
     function ParseSimpleType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String; IsFull : Boolean = False): TPasType;
-    function ParseAliasType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String): TPasTypeAliasType;
+    function ParseAliasType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String): TPasType;
     function ParseTypeReference(Parent: TPasElement; NeedExpr: boolean; out Expr: TPasExpr): TPasType;
     function ParsePointerType(Parent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String): TPasPointerType;
     Function ParseArrayType(Parent : TPasElement; Const NamePos: TPasSourcePos; Const TypeName : String; PackMode : TPackMode) : TPasArrayType;
@@ -765,6 +766,11 @@ begin
     El.SourceEndLinenumber := CurrentParser.CurSourcePos.Row;
 end;
 
+procedure TPasTreeContainer.FinishTypeAlias(var aType: TPasType);
+begin
+  if aType=nil then ;
+end;
+
 function TPasTreeContainer.FindModule(const AName: String): TPasModule;
 begin
   if AName='' then ;  // avoid compiler warning
@@ -1435,14 +1441,15 @@ end;
 
 // On entry, we're on the TYPE token
 function TPasParser.ParseAliasType(Parent: TPasElement;
-  const NamePos: TPasSourcePos; const TypeName: String): TPasTypeAliasType;
+  const NamePos: TPasSourcePos; const TypeName: String): TPasType;
 var
   ok: Boolean;
 begin
   Result := TPasTypeAliasType(CreateElement(TPasTypeAliasType, TypeName, Parent, NamePos));
   ok:=false;
   try
-    Result.DestType := ParseType(Result,NamePos,'');
+    TPasTypeAliasType(Result).DestType := ParseType(Result,NamePos,'');
+    Engine.FinishTypeAlias(Result);
     Engine.FinishScope(stTypeDef,Result);
     ok:=true;
   finally
@@ -1594,8 +1601,8 @@ Const
   // Parsing of these types already takes care of hints
   NoHintTokens = [tkProcedure,tkFunction];
 var
-  PM : TPackMode;
-  CH , isHelper,ok: Boolean; // Check hint ?
+  PM: TPackMode;
+  CH, isHelper, ok: Boolean;
 begin
   Result := nil;
   // NextToken and check pack mode
@@ -2263,8 +2270,8 @@ begin
   end;
 end;
 
-function TPasParser.DoParseExpression(AParent: TPasElement; InitExpr: TPasExpr;
-  AllowEqual : Boolean = True): TPasExpr;
+function TPasParser.DoParseExpression(AParent: TPaselement; InitExpr: TPasExpr;
+  AllowEqual: Boolean): TPasExpr;
 type
   TOpStackItem = record
     Token: TToken;

packages/fcl-passrc/tests/tcresolver.pas

@@ -184,7 +184,7 @@ type
     Procedure TestAliasType_UnitPrefix;
     Procedure TestAliasType_UnitPrefix_CycleFail;
     Procedure TestAliasTypeNotFoundPosition;
-    Procedure TestTypeAliasType; // ToDo
+    Procedure TestTypeAliasType;
 
     // vars, const
     Procedure TestVarLongint;
@@ -361,6 +361,7 @@ type
     Procedure TestProcParamAccess;
     Procedure TestFunctionResult;
     Procedure TestProcedureResultFail;
+    Procedure TestProc_ArgVarTypeAlias;
     Procedure TestProcOverload;
     Procedure TestProcOverloadImplDuplicateFail;
     Procedure TestProcOverloadImplDuplicate2Fail;
@@ -371,6 +372,8 @@ type
     Procedure TestProcCallLowPrecision;
     Procedure TestProcOverloadUntyped;
     Procedure TestProcOverloadMultiLowPrecisionFail;
+    Procedure TestProcOverload_TypeAlias;
+    Procedure TestProcOverload_TypeAliasLiteralFail;
     Procedure TestProcOverloadWithClassTypes;
     Procedure TestProcOverloadWithInhClassTypes;
     Procedure TestProcOverloadWithInhAliasClassTypes;
@@ -524,6 +527,7 @@ type
     Procedure TestClass_Enumerator;
     Procedure TestClass_EnumeratorFunc;
     Procedure TestClass_ForInPropertyStaticArray;
+    Procedure TestClass_TypeAlias;
     // Todo: Fail to use class.method in constant or type, e.g. const p = @o.doit;
 
     // published
@@ -2298,20 +2302,21 @@ end;
 
 procedure TTestResolver.TestTypeAliasType;
 begin
-  // ToDo
   StartProgram(false);
-  Add('type');
-  Add('  {#integer}integer = longint;');
-  Add('  {#tcolor}TColor = type integer;');
-  Add('var');
-  Add('  {=integer}i: integer;');
-  Add('  {=tcolor}c: TColor;');
-  Add('begin');
-  Add('  c:=i;');
-  Add('  i:=c;');
-  Add('  i:=integer(c);');
-  Add('  c:=TColor(i);');
-  // ParseProgram;
+  Add([
+  'type',
+  '  {#integer}integer = longint;',
+  '  {#tcolor}TColor = type integer;',
+  'var',
+  '  {=integer}i: integer;',
+  '  {=tcolor}c: TColor;',
+  'begin',
+  '  c:=i;',
+  '  i:=c;',
+  '  i:=integer(c);',
+  '  c:=TColor(i);',
+  '']);
+  ParseProgram;
 end;
 
 procedure TTestResolver.TestVarLongint;
@@ -5365,6 +5370,7 @@ begin
   Add('var i: integer;');
   Add('begin');
   Add('  DoIt(i,i,i);');
+  Add('  DoIt(1,1,i);');
   ParseProgram;
 end;
 
@@ -5389,6 +5395,26 @@ begin
     nParserExpectTokenError);
 end;
 
+procedure TTestResolver.TestProc_ArgVarTypeAlias;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TColor = type longint;',
+  'procedure DoColor(var c: TColor); external;',
+  'procedure DoInt(var i: longint); external;',
+  'var',
+  '  i: longint;',
+  '  c: TColor;',
+  'begin',
+  '  DoColor(c);',
+  '  DoColor(i);',
+  '  DoInt(i);',
+  '  DoInt(c);',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestProcOverload;
 var
   El: TPasElement;
@@ -5569,6 +5595,44 @@ begin
     nCantDetermineWhichOverloadedFunctionToCall);
 end;
 
+procedure TTestResolver.TestProcOverload_TypeAlias;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TValue = type longint;',
+  '  TAliasValue = TValue;',
+  '  TColor = type TAliasValue;',
+  '  TAliasColor = TColor;',
+  'procedure DoIt(i: TAliasValue); external;',
+  'procedure DoIt(i: TAliasColor); external;',
+  'var',
+  '  v: TAliasValue;',
+  '  c: TAliasColor;',
+  'begin',
+  '  DoIt(v);',
+  '  DoIt(c);',
+  '']);
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestProcOverload_TypeAliasLiteralFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  integer = longint;',
+  '  TValue = type longint;',
+  '  TAliasValue = TValue;',
+  'procedure DoIt(i: integer); external;',
+  'procedure DoIt(i: TAliasValue); external;',
+  'begin',
+  '  DoIt(1);',
+  '']);
+  CheckResolverException('Can''t determine which overloaded function to call, afile.pp(7,15), afile.pp(6,15)',
+    nCantDetermineWhichOverloadedFunctionToCall);
+end;
+
 procedure TTestResolver.TestProcOverloadWithClassTypes;
 begin
   StartProgram(false);
@@ -8891,6 +8955,23 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestClass_TypeAlias;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  TBird = type TObject;',
+  'var',
+  '  o: TObject;',
+  '  b: TBird;',
+  'begin',
+  '  o:=b;',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestClass_PublishedClassVarFail;
 begin
   StartProgram(false);