paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 21:11:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: resolver: allow overriding names of base types

Browse Source 
git-svn-id: trunk@35868 -
This commit is contained in:
Mattias Gaertner 2017-04-21 08:30:28 +00:00
parent 798c1c71e6
commit 74899a889a
2 changed files with 205 additions and 195 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

398
packages/fcl-passrc/src/pasresolver.pp
View File

@ -427,7 +427,7 @@ const
]; ];
btArrayRangeTypes = btAllChars+[btBoolean]+btAllInteger; btArrayRangeTypes = btAllChars+[btBoolean]+btAllInteger;
BaseTypeNames: array[TResolverBaseType] of shortstring =( ResBaseTypeNames: array[TResolverBaseType] of string =(
'None', 'None',
'Custom', 'Custom',
'Context', 'Context',
@ -505,7 +505,7 @@ type
); );
TResolverBuiltInProcs = set of TResolverBuiltInProc; TResolverBuiltInProcs = set of TResolverBuiltInProc;
const const
ResolverBuiltInProcNames: array[TResolverBuiltInProc] of shortstring = ( ResolverBuiltInProcNames: array[TResolverBuiltInProc] of string = (
'Custom', 'Custom',
'Length', 'Length',
'SetLength', 'SetLength',
@ -1002,7 +1002,8 @@ type
private private
type type
TResolveDataListKind = (lkBuiltIn,lkModule); TResolveDataListKind = (lkBuiltIn,lkModule);
procedure ClearResolveDataList(Kind: TResolveDataListKind); function GetBaseTypes(bt: TResolverBaseType): TPasUnresolvedSymbolRef; inline;
function GetScopes(Index: integer): TPasScope; inline;
private private
FAnonymousElTypePostfix: String; FAnonymousElTypePostfix: String;
FBaseTypeChar: TResolverBaseType; FBaseTypeChar: TResolverBaseType;
@ -1032,8 +1033,8 @@ type
FSubScopeCount: integer; FSubScopeCount: integer;
FSubScopes: array of TPasScope; // stack of scopes FSubScopes: array of TPasScope; // stack of scopes
FTopScope: TPasScope; FTopScope: TPasScope;
function GetBaseTypes(bt: TResolverBaseType): TPasUnresolvedSymbolRef; inline; procedure ClearResolveDataList(Kind: TResolveDataListKind);
function GetScopes(Index: integer): TPasScope; inline; function GetBaseTypeNames(bt: TResolverBaseType): string;
protected protected
const const
cIncompatible = High(integer); cIncompatible = High(integer);
@ -1410,6 +1411,10 @@ type
function ResolvedElCanBeVarParam(const ResolvedEl: TPasResolverResult): boolean; function ResolvedElCanBeVarParam(const ResolvedEl: TPasResolverResult): boolean;
function ResolvedElIsClassInstance(const ResolvedEl: TPasResolverResult): boolean; function ResolvedElIsClassInstance(const ResolvedEl: TPasResolverResult): boolean;
// uility functions // uility functions
property BaseTypeNames[bt: TResolverBaseType]: string read GetBaseTypeNames;
function GetProcTypeDescription(ProcType: TPasProcedureType; UseName: boolean = true; AddPaths: boolean = false): string;
function GetResolverResultDescription(const T: TPasResolverResult; OnlyType: boolean = false): string;
function GetTypeDescription(aType: TPasType; AddPath: boolean = false): string;
function GetTypeDescription(const R: TPasResolverResult; AddPath: boolean = false): string; virtual; function GetTypeDescription(const R: TPasResolverResult; AddPath: boolean = false): string; virtual;
function GetBaseDescription(const R: TPasResolverResult; AddPath: boolean = false): string; virtual; function GetBaseDescription(const R: TPasResolverResult; AddPath: boolean = false): string; virtual;
function GetPasPropertyType(El: TPasProperty): TPasType; function GetPasPropertyType(El: TPasProperty): TPasType;
@ -1475,10 +1480,7 @@ type
end; end;
function GetObjName(o: TObject): string; function GetObjName(o: TObject): string;
function GetProcDesc(ProcType: TPasProcedureType; UseName: boolean = true; AddPaths: boolean = false): string; function GetTreeDbg(El: TPasElement; Indent: integer = 0): string;
function GetTypeDesc(aType: TPasType; AddPath: boolean = false): string;
function GetTreeDesc(El: TPasElement; Indent: integer = 0): string;
function GetResolverResultDescription(const T: TPasResolverResult; OnlyType: boolean = false): string;
function GetResolverResultDbg(const T: TPasResolverResult): string; function GetResolverResultDbg(const T: TPasResolverResult): string;
function ResolverResultFlagsToStr(const Flags: TPasResolverResultFlags): string; function ResolverResultFlagsToStr(const Flags: TPasResolverResultFlags): string;
@ -1511,85 +1513,7 @@ begin
Result:=o.ClassName; Result:=o.ClassName;
end; end;
function GetProcDesc(ProcType: TPasProcedureType; UseName: boolean; function GetTreeDbg(El: TPasElement; Indent: integer): string;
AddPaths: boolean): string;
var
Args: TFPList;
i: Integer;
Arg: TPasArgument;
begin
if ProcType=nil then exit('nil');
Result:=ProcType.TypeName;
if ProcType.IsReferenceTo then
Result:=ProcTypeModifiers[ptmReferenceTo]+' '+Result;
if UseName and (ProcType.Parent is TPasProcedure) then
begin
if AddPaths then
Result:=Result+' '+ProcType.Parent.FullName
else
Result:=Result+' '+ProcType.Parent.Name;
end;
Args:=ProcType.Args;
if Args.Count>0 then
begin
Result:=Result+'(';
for i:=0 to Args.Count-1 do
begin
if i>0 then Result:=Result+';';
Arg:=TPasArgument(Args[i]);
if AccessNames[Arg.Access]<>'' then
Result:=Result+AccessNames[Arg.Access];
if Arg.ArgType=nil then
Result:=Result+'untyped'
else
Result:=Result+GetTypeDesc(Arg.ArgType,AddPaths);
end;
Result:=Result+')';
end;
if ProcType.IsOfObject then
Result:=Result+' '+ProcTypeModifiers[ptmOfObject];
if ProcType.IsNested then
Result:=Result+' '+ProcTypeModifiers[ptmIsNested];
if cCallingConventions[ProcType.CallingConvention]<>'' then
Result:=Result+';'+cCallingConventions[ProcType.CallingConvention];
end;
function GetTypeDesc(aType: TPasType; AddPath: boolean): string;
function GetName: string;
var
s: String;
begin
Result:=aType.Name;
if Result='' then
Result:=aType.ElementTypeName;
if AddPath then
begin
s:=aType.FullPath;
if (s<>'') and (s<>'.') then
Result:=s+'.'+Result;
end;
end;
var
C: TClass;
begin
if aType=nil then exit('untyped');
C:=aType.ClassType;
if (C=TPasUnresolvedSymbolRef) then
begin
Result:=GetName;
if TPasUnresolvedSymbolRef(aType).CustomData is TResElDataBuiltInProc then
Result:=Result+'()';
exit;
end
else if (C=TPasUnresolvedTypeRef) then
Result:=GetName
else
Result:=GetName;
end;
function GetTreeDesc(El: TPasElement; Indent: integer): string;
procedure LineBreak(SubIndent: integer); procedure LineBreak(SubIndent: integer);
begin begin
@ -1607,11 +1531,11 @@ begin
if El.ClassType<>TBinaryExpr then if El.ClassType<>TBinaryExpr then
Result:=Result+OpcodeStrings[TPasExpr(El).OpCode]; Result:=Result+OpcodeStrings[TPasExpr(El).OpCode];
if El.ClassType=TUnaryExpr then if El.ClassType=TUnaryExpr then
Result:=Result+GetTreeDesc(TUnaryExpr(El).Operand,Indent) Result:=Result+GetTreeDbg(TUnaryExpr(El).Operand,Indent)
else if El.ClassType=TBinaryExpr then else if El.ClassType=TBinaryExpr then
Result:=Result+'Left={'+GetTreeDesc(TBinaryExpr(El).left,Indent)+'}' Result:=Result+'Left={'+GetTreeDbg(TBinaryExpr(El).left,Indent)+'}'
+OpcodeStrings[TPasExpr(El).OpCode] +OpcodeStrings[TPasExpr(El).OpCode]
+'Right={'+GetTreeDesc(TBinaryExpr(El).right,Indent)+'}' +'Right={'+GetTreeDbg(TBinaryExpr(El).right,Indent)+'}'
else if El.ClassType=TPrimitiveExpr then else if El.ClassType=TPrimitiveExpr then
Result:=Result+TPrimitiveExpr(El).Value Result:=Result+TPrimitiveExpr(El).Value
else if El.ClassType=TBoolConstExpr then else if El.ClassType=TBoolConstExpr then
@ -1625,7 +1549,7 @@ begin
else if El.ClassType=TParamsExpr then else if El.ClassType=TParamsExpr then
begin begin
LineBreak(2); LineBreak(2);
Result:=Result+GetTreeDesc(TParamsExpr(El).Value,Indent)+'('; Result:=Result+GetTreeDbg(TParamsExpr(El).Value,Indent)+'(';
l:=length(TParamsExpr(El).Params); l:=length(TParamsExpr(El).Params);
if l>0 then if l>0 then
begin begin
@ -1633,7 +1557,7 @@ begin
for i:=0 to l-1 do for i:=0 to l-1 do
begin begin
LineBreak(0); LineBreak(0);
Result:=Result+GetTreeDesc(TParamsExpr(El).Params[i],Indent); Result:=Result+GetTreeDbg(TParamsExpr(El).Params[i],Indent);
if i<l-1 then if i<l-1 then
Result:=Result+',' Result:=Result+','
end; end;
@ -1652,7 +1576,7 @@ begin
begin begin
LineBreak(0); LineBreak(0);
Result:=Result+TRecordValues(El).Fields[i].Name+':' Result:=Result+TRecordValues(El).Fields[i].Name+':'
+GetTreeDesc(TRecordValues(El).Fields[i].ValueExp,Indent); +GetTreeDbg(TRecordValues(El).Fields[i].ValueExp,Indent);
if i<l-1 then if i<l-1 then
Result:=Result+',' Result:=Result+','
end; end;
@ -1670,7 +1594,7 @@ begin
for i:=0 to l-1 do for i:=0 to l-1 do
begin begin
LineBreak(0); LineBreak(0);
Result:=Result+GetTreeDesc(TArrayValues(El).Values[i],Indent); Result:=Result+GetTreeDbg(TArrayValues(El).Values[i],Indent);
if i<l-1 then if i<l-1 then
Result:=Result+',' Result:=Result+','
end; end;
@ -1681,7 +1605,7 @@ begin
end end
else if El is TPasProcedure then else if El is TPasProcedure then
begin begin
Result:=Result+GetTreeDesc(TPasProcedure(El).ProcType,Indent); Result:=Result+GetTreeDbg(TPasProcedure(El).ProcType,Indent);
end end
else if El is TPasProcedureType then else if El is TPasProcedureType then
begin begin
@ -1695,7 +1619,7 @@ begin
for i:=0 to l-1 do for i:=0 to l-1 do
begin begin
LineBreak(0); LineBreak(0);
Result:=Result+GetTreeDesc(TPasArgument(TPasProcedureType(El).Args[i]),Indent); Result:=Result+GetTreeDbg(TPasArgument(TPasProcedureType(El).Args[i]),Indent);
if i<l-1 then if i<l-1 then
Result:=Result+';' Result:=Result+';'
end; end;
@ -1703,7 +1627,7 @@ begin
end; end;
Result:=Result+')'; Result:=Result+')';
if El is TPasFunction then if El is TPasFunction then
Result:=Result+':'+GetTreeDesc(TPasFunctionType(TPasFunction(El).ProcType).ResultEl,Indent); Result:=Result+':'+GetTreeDbg(TPasFunctionType(TPasFunction(El).ProcType).ResultEl,Indent);
if TPasProcedureType(El).IsOfObject then if TPasProcedureType(El).IsOfObject then
Result:=Result+' '+ProcTypeModifiers[ptmOfObject]; Result:=Result+' '+ProcTypeModifiers[ptmOfObject];
if TPasProcedureType(El).IsNested then if TPasProcedureType(El).IsNested then
@ -1712,7 +1636,7 @@ begin
Result:=Result+'; '+cCallingConventions[TPasProcedureType(El).CallingConvention]; Result:=Result+'; '+cCallingConventions[TPasProcedureType(El).CallingConvention];
end end
else if El.ClassType=TPasResultElement then else if El.ClassType=TPasResultElement then
Result:=Result+GetTreeDesc(TPasResultElement(El).ResultType,Indent) Result:=Result+GetTreeDbg(TPasResultElement(El).ResultType,Indent)
else if El.ClassType=TPasArgument then else if El.ClassType=TPasArgument then
begin begin
if AccessNames[TPasArgument(El).Access]<>'' then if AccessNames[TPasArgument(El).Access]<>'' then
@ -1720,7 +1644,7 @@ begin
if TPasArgument(El).ArgType=nil then if TPasArgument(El).ArgType=nil then
Result:=Result+'untyped' Result:=Result+'untyped'
else else
Result:=Result+GetTreeDesc(TPasArgument(El).ArgType,Indent); Result:=Result+GetTreeDbg(TPasArgument(El).ArgType,Indent);
end end
else if El.ClassType=TPasUnresolvedSymbolRef then else if El.ClassType=TPasUnresolvedSymbolRef then
begin begin
@ -1729,64 +1653,11 @@ begin
end; end;
end; end;
function GetResolverResultDescription(const T: TPasResolverResult;
OnlyType: boolean): string;
function GetSubTypeName: string;
begin
if (T.TypeEl<>nil) and (T.TypeEl.Name<>'') then
Result:=T.TypeEl.Name
else
Result:=BaseTypeNames[T.SubType];
end;
var
ArrayEl: TPasArrayType;
begin
case T.BaseType of
btModule: exit(T.IdentEl.ElementTypeName+' '+T.IdentEl.Name);
btNil: exit('nil');
btRange:
Result:='range of '+GetSubTypeName;
btSet:
Result:='set/array literal of '+GetSubTypeName;
btContext:
begin
if T.TypeEl.ClassType=TPasClassOfType then
Result:='class of '+TPasClassOfType(T.TypeEl).DestType.Name
else if T.TypeEl.ClassType=TPasAliasType then
Result:=TPasAliasType(T.TypeEl).DestType.Name
else if T.TypeEl.ClassType=TPasTypeAliasType then
Result:='type '+TPasAliasType(T.TypeEl).DestType.Name
else if T.TypeEl.ClassType=TPasArrayType then
begin
ArrayEl:=TPasArrayType(T.TypeEl);
if length(ArrayEl.Ranges)=0 then
Result:='array of '+ArrayEl.ElType.Name
else
Result:='static array[] of '+ArrayEl.ElType.Name;
end
else if T.TypeEl is TPasProcedureType then
Result:=GetProcDesc(TPasProcedureType(T.TypeEl),false)
else if T.TypeEl.Name<>'' then
Result:=T.TypeEl.Name
else
Result:=T.TypeEl.ElementTypeName;
end;
btCustom:
Result:=T.TypeEl.Name;
else
Result:=BaseTypeNames[T.BaseType];
end;
if (not OnlyType) and (T.TypeEl<>T.IdentEl) and (T.IdentEl<>nil) then
Result:=T.IdentEl.Name+':'+Result;
end;
function GetResolverResultDbg(const T: TPasResolverResult): string; function GetResolverResultDbg(const T: TPasResolverResult): string;
begin begin
Result:='[bt='+BaseTypeNames[T.BaseType]; Result:='[bt='+ResBaseTypeNames[T.BaseType];
if T.SubType<>btNone then if T.SubType<>btNone then
Result:=Result+' Sub='+BaseTypeNames[T.SubType]; Result:=Result+' Sub='+ResBaseTypeNames[T.SubType];
Result:=Result Result:=Result
+' Ident='+GetObjName(T.IdentEl) +' Ident='+GetObjName(T.IdentEl)
+' Type='+GetObjName(T.TypeEl) +' Type='+GetObjName(T.TypeEl)
@ -1985,7 +1856,7 @@ end;
procedure TPasWithExprScope.WriteIdentifiers(Prefix: string); procedure TPasWithExprScope.WriteIdentifiers(Prefix: string);
begin begin
writeln(Prefix+'WithExpr: '+GetTreeDesc(Expr,length(Prefix))); writeln(Prefix+'WithExpr: '+GetTreeDbg(Expr,length(Prefix)));
Scope.WriteIdentifiers(Prefix); Scope.WriteIdentifiers(Prefix);
end; end;
@ -2448,7 +2319,7 @@ procedure TPasIdentifierScope.InternalAdd(Item: TPasIdentifier);
var var
Index: Integer; Index: Integer;
OldItem: TPasIdentifier; OldItem: TPasIdentifier;
LoName: ShortString; LoName: string;
begin begin
LoName:=lowercase(Item.Identifier); LoName:=lowercase(Item.Identifier);
Index:=FItems.FindIndexOf(LoName); Index:=FItems.FindIndexOf(LoName);
@ -2514,7 +2385,7 @@ end;
function TPasIdentifierScope.RemoveLocalIdentifier(El: TPasElement): boolean; function TPasIdentifierScope.RemoveLocalIdentifier(El: TPasElement): boolean;
var var
Identifier, PrevIdentifier: TPasIdentifier; Identifier, PrevIdentifier: TPasIdentifier;
LoName: ShortString; LoName: string;
begin begin
LoName:=lowercase(El.Name); LoName:=lowercase(El.Name);
Identifier:=TPasIdentifier(FItems.Find(LoName)); Identifier:=TPasIdentifier(FItems.Find(LoName));
@ -2640,8 +2511,8 @@ end;
// inline // inline
function TPasResolver.IsNameExpr(El: TPasExpr): boolean; function TPasResolver.IsNameExpr(El: TPasExpr): boolean;
begin begin
if El.ClassType=TSelfExpr then exit(true); Result:=(El.ClassType=TSelfExpr)
Result:=(El.ClassType=TPrimitiveExpr) and (TPrimitiveExpr(El).Kind=pekIdent); or ((El.ClassType=TPrimitiveExpr) and (TPrimitiveExpr(El).Kind=pekIdent));
end; end;
procedure TPasResolver.ClearResolveDataList(Kind: TResolveDataListKind); procedure TPasResolver.ClearResolveDataList(Kind: TResolveDataListKind);
@ -2660,6 +2531,14 @@ begin
end; end;
end; end;
function TPasResolver.GetBaseTypeNames(bt: TResolverBaseType): string;
begin
if FBaseTypes[bt]<>nil then
Result:=FBaseTypes[bt].Name
else
Result:=ResBaseTypeNames[bt];
end;
procedure TPasResolver.OnFindFirstElement(El: TPasElement; ElScope, procedure TPasResolver.OnFindFirstElement(El: TPasElement; ElScope,
StartScope: TPasScope; FindFirstElementData: Pointer; var Abort: boolean); StartScope: TPasScope; FindFirstElementData: Pointer; var Abort: boolean);
var var
@ -2746,7 +2625,7 @@ begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.OnFindCallElements Proc Distance=',Distance, writeln('TPasResolver.OnFindCallElements Proc Distance=',Distance,
' Data^.Found=',Data^.Found<>nil,' Data^.Distance=',ord(Data^.Distance), ' Data^.Found=',Data^.Found<>nil,' Data^.Distance=',ord(Data^.Distance),
' Signature={',GetProcDesc(Proc.ProcType,true,true),'}'); ' Signature={',GetProcTypeDescription(Proc.ProcType,true,true),'}');
{$ENDIF} {$ENDIF}
CandidateFound:=true; CandidateFound:=true;
end end
@ -2884,10 +2763,10 @@ begin
if (Data^.List.IndexOf(El)>=0) then if (Data^.List.IndexOf(El)>=0) then
begin begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.OnFindCallElements Found El twice: ',GetTreeDesc(El), writeln('TPasResolver.OnFindCallElements Found El twice: ',GetTreeDbg(El),
' ',GetElementSourcePosStr(El), ' ',GetElementSourcePosStr(El),
' PrevElScope=',GetObjName(Data^.ElScope),' ',GetTreeDesc(Data^.ElScope.Element), ' PrevElScope=',GetObjName(Data^.ElScope),' ',GetTreeDbg(Data^.ElScope.Element),
' ElScope=',GetObjName(ElScope),' ',GetTreeDesc(ElScope.Element) ' ElScope=',GetObjName(ElScope),' ',GetTreeDbg(ElScope.Element)
); );
{$ENDIF} {$ENDIF}
RaiseInternalError(20160924230805); RaiseInternalError(20160924230805);
@ -2959,7 +2838,7 @@ begin
end; end;
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.OnFindOverloadProc ',GetTreeDesc(El,2)); writeln('TPasResolver.OnFindOverloadProc ',GetTreeDbg(El,2));
{$ENDIF} {$ENDIF}
Proc:=TPasProcedure(El); Proc:=TPasProcedure(El);
if CheckOverloadProcCompatibility(Data^.Proc,Proc) then if CheckOverloadProcCompatibility(Data^.Proc,Proc) then
@ -3439,7 +3318,7 @@ begin
CheckTopScope(TPasProcedureScope); CheckTopScope(TPasProcedureScope);
Proc:=TPasProcedure(El.Parent); Proc:=TPasProcedure(El.Parent);
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishProcedureHeader El=',GetTreeDesc(El),' ',GetElementSourcePosStr(El),' IsForward=',Proc.IsForward,' Parent=',GetObjName(El.Parent)); writeln('TPasResolver.FinishProcedureHeader El=',GetTreeDbg(El),' ',GetElementSourcePosStr(El),' IsForward=',Proc.IsForward,' Parent=',GetObjName(El.Parent));
{$ENDIF} {$ENDIF}
ProcName:=Proc.Name; ProcName:=Proc.Name;
@ -3563,7 +3442,7 @@ begin
// overload found with same signature // overload found with same signature
DeclProc:=FindData.Found; DeclProc:=FindData.Found;
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishProcedureHeader overload found: Proc2=',GetTreeDesc(DeclProc),' ',GetElementSourcePosStr(DeclProc),' IsForward=',DeclProc.IsForward,' Parent=',GetObjName(DeclProc.Parent)); writeln('TPasResolver.FinishProcedureHeader overload found: Proc2=',GetTreeDbg(DeclProc),' ',GetElementSourcePosStr(DeclProc),' IsForward=',DeclProc.IsForward,' Parent=',GetObjName(DeclProc.Parent));
{$ENDIF} {$ENDIF}
if (Proc.Parent=DeclProc.Parent) if (Proc.Parent=DeclProc.Parent)
or ((Proc.Parent is TImplementationSection) or ((Proc.Parent is TImplementationSection)
@ -3637,7 +3516,7 @@ begin
// no overload // no overload
if Proc.IsOverride then if Proc.IsOverride then
RaiseMsg(20170216151702,nNoMethodInAncestorToOverride, RaiseMsg(20170216151702,nNoMethodInAncestorToOverride,
sNoMethodInAncestorToOverride,[GetProcDesc(Proc.ProcType)],Proc.ProcType); sNoMethodInAncestorToOverride,[GetProcTypeDescription(Proc.ProcType)],Proc.ProcType);
end end
else else
begin begin
@ -3653,7 +3532,7 @@ begin
if (not OverloadProc.IsVirtual) and (not OverloadProc.IsOverride) then if (not OverloadProc.IsVirtual) and (not OverloadProc.IsOverride) then
// the OverloadProc fits the signature, but is not virtual // the OverloadProc fits the signature, but is not virtual
RaiseMsg(20170216151708,nNoMethodInAncestorToOverride, RaiseMsg(20170216151708,nNoMethodInAncestorToOverride,
sNoMethodInAncestorToOverride,[GetProcDesc(Proc.ProcType)],Proc.ProcType); sNoMethodInAncestorToOverride,[GetProcTypeDescription(Proc.ProcType)],Proc.ProcType);
// override a virtual method // override a virtual method
CheckProcSignatureMatch(OverloadProc,Proc); CheckProcSignatureMatch(OverloadProc,Proc);
// check visibility // check visibility
@ -4034,8 +3913,8 @@ begin
// check function result type // check function result type
ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType; ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType;
if not IsSameType(ResultType,PropType) then if not IsSameType(ResultType,PropType) then
RaiseXExpectedButYFound(20170216151844,'function result '+GetTypeDesc(PropType,true), RaiseXExpectedButYFound(20170216151844,'function result '+GetTypeDescription(PropType,true),
GetTypeDesc(ResultType,true),PropEl.ReadAccessor); GetTypeDescription(ResultType,true),PropEl.ReadAccessor);
// check args // check args
CheckArgs(Proc,PropEl.ReadAccessor); CheckArgs(Proc,PropEl.ReadAccessor);
if Proc.ProcType.Args.Count<>PropEl.Args.Count then if Proc.ProcType.Args.Count<>PropEl.Args.Count then
@ -4133,7 +4012,7 @@ begin
ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType; ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType;
if not IsBaseType(ResultType,btBoolean) then if not IsBaseType(ResultType,btBoolean) then
RaiseXExpectedButYFound(20170216151929,'function: boolean', RaiseXExpectedButYFound(20170216151929,'function: boolean',
'function:'+GetTypeDesc(ResultType),PropEl.StoredAccessor); 'function:'+GetTypeDescription(ResultType),PropEl.StoredAccessor);
// check arg count // check arg count
if Proc.ProcType.Args.Count<>0 then if Proc.ProcType.Args.Count<>0 then
RaiseMsg(20170216151932,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo, RaiseMsg(20170216151932,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo,
@ -4220,7 +4099,7 @@ begin
end; end;
end end
else if AncestorType.ClassType<>TPasClassType then else if AncestorType.ClassType<>TPasClassType then
RaiseXExpectedButYFound(20170216151944,'class type',GetTypeDesc(AncestorType),aClass) RaiseXExpectedButYFound(20170216151944,'class type',GetTypeDescription(AncestorType),aClass)
else else
begin begin
AncestorEl:=TPasClassType(AncestorType); AncestorEl:=TPasClassType(AncestorType);
@ -4501,7 +4380,7 @@ begin
end; end;
if not ok then if not ok then
RaiseXExpectedButYFound(20170216151952,'ordinal expression', RaiseXExpectedButYFound(20170216151952,'ordinal expression',
GetTypeDesc(CaseExprResolved.TypeEl),CaseOf.CaseExpr); GetTypeDescription(CaseExprResolved.TypeEl),CaseOf.CaseExpr);
for i:=0 to CaseOf.Elements.Count-1 do for i:=0 to CaseOf.Elements.Count-1 do
begin begin
@ -4885,7 +4764,7 @@ var
DeclProc, AncestorProc: TPasProcedure; DeclProc, AncestorProc: TPasProcedure;
begin begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveInherited El.Parent=',GetTreeDesc(El.Parent)); writeln('TPasResolver.ResolveInherited El.Parent=',GetTreeDbg(El.Parent));
{$ENDIF} {$ENDIF}
if (El.Parent.ClassType=TBinaryExpr) if (El.Parent.ClassType=TBinaryExpr)
and (TBinaryExpr(El.Parent).OpCode=eopNone) then and (TBinaryExpr(El.Parent).OpCode=eopNone) then
@ -4940,7 +4819,7 @@ var
InhScope: TPasDotClassScope; InhScope: TPasDotClassScope;
begin begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveInheritedCall El=',GetTreeDesc(El)); writeln('TPasResolver.ResolveInheritedCall El=',GetTreeDbg(El));
{$ENDIF} {$ENDIF}
CheckTopScope(TPasProcedureScope); CheckTopScope(TPasProcedureScope);
@ -5249,12 +5128,12 @@ begin
begin begin
El:=TPasElement(FindCallData.List[i]); El:=TPasElement(FindCallData.List[i]);
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveFuncParamsExpr Overload Candidate: ',GetElementSourcePosStr(El),' ',GetTreeDesc(El)); writeln('TPasResolver.ResolveFuncParamsExpr Overload Candidate: ',GetElementSourcePosStr(El),' ',GetTreeDbg(El));
{$ENDIF} {$ENDIF}
// emit a hint for each candidate // emit a hint for each candidate
if El is TPasProcedure then if El is TPasProcedure then
LogMsg(20170417180320,mtHint,nFoundCallCandidateX,sFoundCallCandidateX, LogMsg(20170417180320,mtHint,nFoundCallCandidateX,sFoundCallCandidateX,
[GetProcDesc(TPasProcedure(El).ProcType,true,true)],El); [GetProcTypeDescription(TPasProcedure(El).ProcType,true,true)],El);
Msg:=Msg+', '+GetElementSourcePosStr(El); Msg:=Msg+', '+GetElementSourcePosStr(El);
end; end;
RaiseMsg(20170216152200,nCantDetermineWhichOverloadedFunctionToCall, RaiseMsg(20170216152200,nCantDetermineWhichOverloadedFunctionToCall,
@ -5508,7 +5387,7 @@ procedure TPasResolver.ResolveSetParamsExpr(Params: TParamsExpr);
// e.g. resolving '[1,2..3]' // e.g. resolving '[1,2..3]'
begin begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.ResolveSetParamsExpr ',GetTreeDesc(Params)); writeln('TPasResolver.ResolveSetParamsExpr ',GetTreeDbg(Params));
{$ENDIF} {$ENDIF}
if Params.Value<>nil then if Params.Value<>nil then
RaiseNotYetImplemented(20160930135910,Params); RaiseNotYetImplemented(20160930135910,Params);
@ -8324,7 +8203,7 @@ begin
then then
// proc needs parameters // proc needs parameters
RaiseMsg(20170216152347,nWrongNumberOfParametersForCallTo, RaiseMsg(20170216152347,nWrongNumberOfParametersForCallTo,
sWrongNumberOfParametersForCallTo,[GetProcDesc(TPasProcedure(Result).ProcType)],ErrorPosEl); sWrongNumberOfParametersForCallTo,[GetProcTypeDescription(TPasProcedure(Result).ProcType)],ErrorPosEl);
end; end;
procedure TPasResolver.IterateElements(const aName: string; procedure TPasResolver.IterateElements(const aName: string;
@ -9170,12 +9049,12 @@ procedure TPasResolver.RaiseIncompatibleType(id: int64; MsgNumber: integer;
var var
DescA, DescB: String; DescA, DescB: String;
begin begin
DescA:=GetTypeDesc(GotType); DescA:=GetTypeDescription(GotType);
DescB:=GetTypeDesc(ExpType); DescB:=GetTypeDescription(ExpType);
if DescA=DescB then if DescA=DescB then
begin begin
DescA:=GetTypeDesc(GotType,true); DescA:=GetTypeDescription(GotType,true);
DescB:=GetTypeDesc(ExpType,true); DescB:=GetTypeDescription(ExpType,true);
end; end;
RaiseIncompatibleTypeDesc(id,MsgNumber,Args,DescA,DescB,ErrorEl); RaiseIncompatibleTypeDesc(id,MsgNumber,Args,DescA,DescB,ErrorEl);
end; end;
@ -9297,7 +9176,7 @@ begin
// too many arguments // too many arguments
if RaiseOnError then if RaiseOnError then
RaiseMsg(20170216152408,nWrongNumberOfParametersForCallTo, RaiseMsg(20170216152408,nWrongNumberOfParametersForCallTo,
sWrongNumberOfParametersForCallTo,[GetProcDesc(ProcType)],Param); sWrongNumberOfParametersForCallTo,[GetProcTypeDescription(ProcType)],Param);
exit(cIncompatible); exit(cIncompatible);
end; end;
end; end;
@ -9311,7 +9190,7 @@ begin
if RaiseOnError then if RaiseOnError then
// ToDo: position cursor on identifier // ToDo: position cursor on identifier
RaiseMsg(20170216152410,nWrongNumberOfParametersForCallTo, RaiseMsg(20170216152410,nWrongNumberOfParametersForCallTo,
sWrongNumberOfParametersForCallTo,[GetProcDesc(ProcType)],Params.Value); sWrongNumberOfParametersForCallTo,[GetProcTypeDescription(ProcType)],Params.Value);
exit(cIncompatible); exit(cIncompatible);
end end
else else
@ -10161,10 +10040,141 @@ begin
exit(true); exit(true);
end; end;
function TPasResolver.GetProcTypeDescription(ProcType: TPasProcedureType;
UseName: boolean; AddPaths: boolean): string;
var
Args: TFPList;
i: Integer;
Arg: TPasArgument;
begin
if ProcType=nil then exit('nil');
Result:=ProcType.TypeName;
if ProcType.IsReferenceTo then
Result:=ProcTypeModifiers[ptmReferenceTo]+' '+Result;
if UseName and (ProcType.Parent is TPasProcedure) then
begin
if AddPaths then
Result:=Result+' '+ProcType.Parent.FullName
else
Result:=Result+' '+ProcType.Parent.Name;
end;
Args:=ProcType.Args;
if Args.Count>0 then
begin
Result:=Result+'(';
for i:=0 to Args.Count-1 do
begin
if i>0 then Result:=Result+';';
Arg:=TPasArgument(Args[i]);
if AccessNames[Arg.Access]<>'' then
Result:=Result+AccessNames[Arg.Access];
if Arg.ArgType=nil then
Result:=Result+'untyped'
else
Result:=Result+GetTypeDescription(Arg.ArgType,AddPaths);
end;
Result:=Result+')';
end;
if ProcType.IsOfObject then
Result:=Result+' '+ProcTypeModifiers[ptmOfObject];
if ProcType.IsNested then
Result:=Result+' '+ProcTypeModifiers[ptmIsNested];
if cCallingConventions[ProcType.CallingConvention]<>'' then
Result:=Result+';'+cCallingConventions[ProcType.CallingConvention];
end;
function TPasResolver.GetResolverResultDescription(const T: TPasResolverResult;
OnlyType: boolean): string;
function GetSubTypeName: string;
begin
if (T.TypeEl<>nil) and (T.TypeEl.Name<>'') then
Result:=T.TypeEl.Name
else
Result:=BaseTypeNames[T.SubType];
end;
var
ArrayEl: TPasArrayType;
begin
case T.BaseType of
btModule: exit(T.IdentEl.ElementTypeName+' '+T.IdentEl.Name);
btNil: exit('nil');
btRange:
Result:='range of '+GetSubTypeName;
btSet:
Result:='set/array literal of '+GetSubTypeName;
btContext:
begin
if T.TypeEl.ClassType=TPasClassOfType then
Result:='class of '+TPasClassOfType(T.TypeEl).DestType.Name
else if T.TypeEl.ClassType=TPasAliasType then
Result:=TPasAliasType(T.TypeEl).DestType.Name
else if T.TypeEl.ClassType=TPasTypeAliasType then
Result:='type '+TPasAliasType(T.TypeEl).DestType.Name
else if T.TypeEl.ClassType=TPasArrayType then
begin
ArrayEl:=TPasArrayType(T.TypeEl);
if length(ArrayEl.Ranges)=0 then
Result:='array of '+ArrayEl.ElType.Name
else
Result:='static array[] of '+ArrayEl.ElType.Name;
end
else if T.TypeEl is TPasProcedureType then
Result:=GetProcTypeDescription(TPasProcedureType(T.TypeEl),false)
else if T.TypeEl.Name<>'' then
Result:=T.TypeEl.Name
else
Result:=T.TypeEl.ElementTypeName;
end;
btCustom:
Result:=T.TypeEl.Name;
else
Result:=BaseTypeNames[T.BaseType];
end;
if (not OnlyType) and (T.TypeEl<>T.IdentEl) and (T.IdentEl<>nil) then
Result:=T.IdentEl.Name+':'+Result;
end;
function TPasResolver.GetTypeDescription(aType: TPasType; AddPath: boolean): string;
function GetName: string;
var
s: String;
begin
Result:=aType.Name;
if Result='' then
Result:=aType.ElementTypeName;
if AddPath then
begin
s:=aType.FullPath;
if (s<>'') and (s<>'.') then
Result:=s+'.'+Result;
end;
end;
var
C: TClass;
begin
if aType=nil then exit('untyped');
C:=aType.ClassType;
if (C=TPasUnresolvedSymbolRef) then
begin
Result:=GetName;
if TPasUnresolvedSymbolRef(aType).CustomData is TResElDataBuiltInProc then
Result:=Result+'()';
exit;
end
else if (C=TPasUnresolvedTypeRef) then
Result:=GetName
else
Result:=GetName;
end;
function TPasResolver.GetTypeDescription(const R: TPasResolverResult; function TPasResolver.GetTypeDescription(const R: TPasResolverResult;
AddPath: boolean): string; AddPath: boolean): string;
begin begin
Result:=GetTypeDesc(R.TypeEl,AddPath); Result:=GetTypeDescription(R.TypeEl,AddPath);
if R.IdentEl=R.TypeEl then if R.IdentEl=R.TypeEl then
begin begin
if R.TypeEl.ElementTypeName<>'' then if R.TypeEl.ElementTypeName<>'' then
@ -10269,10 +10279,10 @@ begin
ComputeElement(Param,ParamResolved,[]); ComputeElement(Param,ParamResolved,[]);
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.CheckParamCompatibility Param=',GetTreeDesc(Param,2),' ParamResolved=',GetResolverResultDbg(ParamResolved)); writeln('TPasResolver.CheckParamCompatibility Param=',GetTreeDbg(Param,2),' ParamResolved=',GetResolverResultDbg(ParamResolved));
{$ENDIF} {$ENDIF}
if (ParamResolved.TypeEl=nil) and (Param.ArgType<>nil) then if (ParamResolved.TypeEl=nil) and (Param.ArgType<>nil) then
RaiseInternalError(20160922163628,'GetResolvedType returned TypeEl=nil for '+GetTreeDesc(Param)); RaiseInternalError(20160922163628,'GetResolvedType returned TypeEl=nil for '+GetTreeDbg(Param));
RHSFlags:=[]; RHSFlags:=[];
if NeedVar then if NeedVar then
Include(RHSFlags,rcNoImplicitProc) Include(RHSFlags,rcNoImplicitProc)
@ -10301,7 +10311,7 @@ begin
ComputeElement(Expr,ExprResolved,RHSFlags); ComputeElement(Expr,ExprResolved,RHSFlags);
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.CheckParamCompatibility Expr=',GetTreeDesc(Expr,2),' ResolvedExpr=',GetResolverResultDbg(ExprResolved),' RHSFlags=',dbgs(RHSFlags)); writeln('TPasResolver.CheckParamCompatibility Expr=',GetTreeDbg(Expr,2),' ResolvedExpr=',GetResolverResultDbg(ExprResolved),' RHSFlags=',dbgs(RHSFlags));
{$ENDIF} {$ENDIF}
if NeedVar then if NeedVar then
@ -11088,7 +11098,7 @@ var
StartFromType, StartToType: TPasArrayType; StartFromType, StartToType: TPasArrayType;
begin begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.CheckTypeCastArray From=',GetTypeDesc(FromType),' ToType=',GetTypeDesc(ToType)); writeln('TPasResolver.CheckTypeCastArray From=',GetTypeDescription(FromType),' ToType=',GetTypeDescription(ToType));
{$ENDIF} {$ENDIF}
StartFromType:=FromType; StartFromType:=FromType;
StartToType:=ToType; StartToType:=ToType;
@ -11098,7 +11108,7 @@ begin
ToIndex:=0; ToIndex:=0;
repeat repeat
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.CheckTypeCastArray From=',GetTypeDesc(FromType),' FromIndex=',FromIndex,' ToType=',GetTypeDesc(ToType),' ToIndex=',ToIndex); writeln('TPasResolver.CheckTypeCastArray From=',GetTypeDescription(FromType),' FromIndex=',FromIndex,' ToType=',GetTypeDescription(ToType),' ToIndex=',ToIndex);
{$ENDIF} {$ENDIF}
if length(ToType.Ranges)=0 then if length(ToType.Ranges)=0 then
// ToType is dynamic/open array -> fits any size // ToType is dynamic/open array -> fits any size
@ -11114,7 +11124,7 @@ begin
if NextDim(ToType,ToIndex,ToElTypeRes) then if NextDim(ToType,ToIndex,ToElTypeRes) then
begin begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.CheckTypeCastArray To has more dims than From: From=',GetTypeDesc(FromType),' FromIndex=',FromIndex,', ToType=',GetTypeDesc(ToType),' ToIndex=',ToIndex); writeln('TPasResolver.CheckTypeCastArray To has more dims than From: From=',GetTypeDescription(FromType),' FromIndex=',FromIndex,', ToType=',GetTypeDescription(ToType),' ToIndex=',ToIndex);
{$ENDIF} {$ENDIF}
break; // ToType has more dimensions break; // ToType has more dimensions
end; end;
@ -11132,7 +11142,7 @@ begin
if not NextDim(ToType,ToIndex,ToElTypeRes) then if not NextDim(ToType,ToIndex,ToElTypeRes) then
begin begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.CheckTypeCastArray From has more dims than To: From=',GetTypeDesc(FromType),' FromIndex=',FromIndex,', ToType=',GetTypeDesc(ToType),' ToIndex=',ToIndex); writeln('TPasResolver.CheckTypeCastArray From has more dims than To: From=',GetTypeDescription(FromType),' FromIndex=',FromIndex,', ToType=',GetTypeDescription(ToType),' ToIndex=',ToIndex);
{$ENDIF} {$ENDIF}
break; // ToType has less dimensions break; // ToType has less dimensions
end; end;

2
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -1634,7 +1634,7 @@ var
var var
s: String; s: String;
begin begin
s:='TTestResolver.OnCheckElementParent El='+GetTreeDesc(El)+' '+ s:='TTestResolver.OnCheckElementParent El='+GetTreeDbg(El)+' '+
ResolverEngine.GetElementSourcePosStr(El)+' '+Msg; ResolverEngine.GetElementSourcePosStr(El)+' '+Msg;
writeln('ERROR: ',s); writeln('ERROR: ',s);
Fail(s); Fail(s);