fcl-passrc: resolver: built-in function typeinfo

git-svn-id: trunk@35791 -
This commit is contained in:
Mattias Gaertner 2017-04-14 15:51:47 +00:00
parent 642ea28368
commit a42fa05288

View File

@ -229,7 +229,7 @@ const
nTypesAreNotRelated = 3029; nTypesAreNotRelated = 3029;
nAbstractMethodsCannotBeCalledDirectly = 3030; nAbstractMethodsCannotBeCalledDirectly = 3030;
nMissingParameterX = 3031; nMissingParameterX = 3031;
nCannotAccessThisMemberFromAClassReference = 3032; nCannotAccessThisMemberFromAX = 3032;
nInOperatorExpectsSetElementButGot = 3033; nInOperatorExpectsSetElementButGot = 3033;
nWrongNumberOfParametersForTypeCast = 3034; nWrongNumberOfParametersForTypeCast = 3034;
nIllegalTypeConversionTo = 3035; nIllegalTypeConversionTo = 3035;
@ -252,6 +252,7 @@ const
nXModifierMismatchY = 3052; nXModifierMismatchY = 3052;
nSymbolCannotBePublished = 3053; nSymbolCannotBePublished = 3053;
nCannotTypecastAType = 3054; nCannotTypecastAType = 3054;
nTypeIdentifierExpected = 3055;
// resourcestring patterns of messages // resourcestring patterns of messages
resourcestring resourcestring
@ -286,7 +287,7 @@ resourcestring
sTypesAreNotRelated = 'Types are not related'; sTypesAreNotRelated = 'Types are not related';
sAbstractMethodsCannotBeCalledDirectly = 'Abstract methods cannot be called directly'; sAbstractMethodsCannotBeCalledDirectly = 'Abstract methods cannot be called directly';
sMissingParameterX = 'Missing parameter %s'; sMissingParameterX = 'Missing parameter %s';
sCannotAccessThisMemberFromAClassReference = 'Cannot access this member from a class reference'; sCannotAccessThisMemberFromAX = 'Cannot access this member from a %s';
sInOperatorExpectsSetElementButGot = 'the in-operator expects a set element, but got %s'; sInOperatorExpectsSetElementButGot = 'the in-operator expects a set element, but got %s';
sWrongNumberOfParametersForTypeCast = 'wrong number of parameters for type cast to %s'; sWrongNumberOfParametersForTypeCast = 'wrong number of parameters for type cast to %s';
sIllegalTypeConversionTo = 'Illegal type conversion: "%s" to "%s"'; sIllegalTypeConversionTo = 'Illegal type conversion: "%s" to "%s"';
@ -307,8 +308,9 @@ resourcestring
sVirtualMethodXHasLowerVisibility = 'Virtual method "%s" has a lower visibility (%s) than parent class %s (%s)'; sVirtualMethodXHasLowerVisibility = 'Virtual method "%s" has a lower visibility (%s) than parent class %s (%s)';
sExternalClassInstanceCannotAccessStaticX = 'External class instance cannot access static %s'; sExternalClassInstanceCannotAccessStaticX = 'External class instance cannot access static %s';
sXModifierMismatchY = '%s modifier "%s" mismatch'; sXModifierMismatchY = '%s modifier "%s" mismatch';
sSymbolCannotBePublished = 'Symbol cannot be published. Only methods and properties.'; sSymbolCannotBePublished = 'Symbol cannot be published';
sCannotTypecastAType = 'Cannot type cast a type'; sCannotTypecastAType = 'Cannot type cast a type';
sTypeIdentifierExpected = 'Type identifier expected';
type type
TResolverBaseType = ( TResolverBaseType = (
@ -443,7 +445,7 @@ const
'Nil', 'Nil',
'Procedure/Function', 'Procedure/Function',
'BuiltInProc', 'BuiltInProc',
'set literal', 'set',
'range..', 'range..',
'array literal' 'array literal'
); );
@ -472,7 +474,8 @@ type
bfConcatArray, bfConcatArray,
bfCopyArray, bfCopyArray,
bfInsertArray, bfInsertArray,
bfDeleteArray bfDeleteArray,
bfTypeInfo
); );
TResolverBuiltInProcs = set of TResolverBuiltInProc; TResolverBuiltInProcs = set of TResolverBuiltInProc;
const const
@ -499,7 +502,8 @@ const
'Concat', 'Concat',
'Copy', 'Copy',
'Insert', 'Insert',
'Delete' 'Delete',
'TypeInfo'
); );
bfAllStandardProcs = [Succ(bfCustom)..high(TResolverBuiltInProc)]; bfAllStandardProcs = [Succ(bfCustom)..high(TResolverBuiltInProc)];
@ -1218,6 +1222,10 @@ type
Expr: TPasExpr; RaiseOnError: boolean): integer; virtual; Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
procedure BI_DeleteArray_OnFinishParamsExpr(Proc: TResElDataBuiltInProc; procedure BI_DeleteArray_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
Params: TParamsExpr); virtual; Params: TParamsExpr); virtual;
function BI_TypeInfo_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
procedure BI_TypeInfo_OnGetCallResult({%H-}Proc: TResElDataBuiltInProc;
{%H-}Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
@ -1359,10 +1367,12 @@ type
function GetPasPropertyAncestor(El: TPasProperty): TPasProperty; function GetPasPropertyAncestor(El: TPasProperty): TPasProperty;
function GetPasPropertyGetter(El: TPasProperty): TPasElement; function GetPasPropertyGetter(El: TPasProperty): TPasElement;
function GetPasPropertySetter(El: TPasProperty): TPasElement; function GetPasPropertySetter(El: TPasProperty): TPasElement;
function GetPasPropertyStored(El: TPasProperty): TPasElement;
function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType; function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType;
function GetLoop(El: TPasElement): TPasImplElement; function GetLoop(El: TPasElement): TPasImplElement;
function ResolveAliasType(aType: TPasType): TPasType; function ResolveAliasType(aType: TPasType): TPasType;
function ExprIsAddrTarget(El: TPasExpr): boolean; function ExprIsAddrTarget(El: TPasExpr): boolean;
function IsNameExpr(El: TPasExpr): boolean; inline; // TSelfExpr or TPrimitiveExpr with Kind=pekIdent
function GetLastExprIdentifier(El: TPasExpr): TPasExpr; function GetLastExprIdentifier(El: TPasExpr): TPasExpr;
function ParentNeedsExprResult(El: TPasExpr): boolean; function ParentNeedsExprResult(El: TPasExpr): boolean;
function GetReference_NewInstanceClass(Ref: TResolvedReference): TPasClassType; function GetReference_NewInstanceClass(Ref: TResolvedReference): TPasClassType;
@ -1376,6 +1386,7 @@ type
function IsTypeCast(Params: TParamsExpr): boolean; function IsTypeCast(Params: TParamsExpr): boolean;
function ProcNeedsParams(El: TPasProcedureType): boolean; function ProcNeedsParams(El: TPasProcedureType): boolean;
function GetRangeLength(RangeResolved: TPasResolverResult): integer; function GetRangeLength(RangeResolved: TPasResolverResult): integer;
function HasTypeInfo(El: TPasType): boolean; virtual;
public public
property BaseTypes[bt: TResolverBaseType]: TPasUnresolvedSymbolRef read GetBaseTypes; property BaseTypes[bt: TResolverBaseType]: TPasUnresolvedSymbolRef read GetBaseTypes;
property BaseTypeStringIndex: TResolverBaseType read FBaseTypeStringIndex write FBaseTypeStringIndex; property BaseTypeStringIndex: TResolverBaseType read FBaseTypeStringIndex write FBaseTypeStringIndex;
@ -2551,6 +2562,13 @@ begin
Result:=FScopes[Index]; Result:=FScopes[Index];
end; end;
// inline
function TPasResolver.IsNameExpr(El: TPasExpr): boolean;
begin
if El.ClassType=TSelfExpr then exit(true);
Result:=(El.ClassType=TPrimitiveExpr) and (TPrimitiveExpr(El).Kind=pekIdent);
end;
procedure TPasResolver.ClearResolveDataList(Kind: TResolveDataListKind); procedure TPasResolver.ClearResolveDataList(Kind: TResolveDataListKind);
var var
El: TPasElement; El: TPasElement;
@ -2864,14 +2882,16 @@ var
ClassScope: TPasClassScope; ClassScope: TPasClassScope;
OlderEl: TPasElement; OlderEl: TPasElement;
IsClassScope: Boolean; IsClassScope: Boolean;
C: TClass;
begin begin
IsClassScope:=(Scope is TPasClassScope); IsClassScope:=(Scope is TPasClassScope);
if (El.Visibility=visPublished) then if (El.Visibility=visPublished) then
begin begin
if El.ClassType=TPasProperty then C:=El.ClassType;
if (C=TPasProperty) or (C=TPasVariable) then
// Note: VarModifiers are not yet set // Note: VarModifiers are not yet set
else if (El.ClassType=TPasProcedure) or (El.ClassType=TPasFunction) then else if (C=TPasProcedure) or (C=TPasFunction) then
// ok // ok
else else
RaiseMsg(20170403223024,nSymbolCannotBePublished,sSymbolCannotBePublished,[],El); RaiseMsg(20170403223024,nSymbolCannotBePublished,sSymbolCannotBePublished,[],El);
@ -3254,6 +3274,7 @@ var
DeclProcScope, ProcScope: TPasProcedureScope; DeclProcScope, ProcScope: TPasProcedureScope;
ParentScope: TPasScope; ParentScope: TPasScope;
pm: TProcedureModifier; pm: TProcedureModifier;
ptm: TProcTypeModifier;
begin begin
if (El.Parent is TPasProcedure) and (TPasProcedure(El.Parent).ProcType=El) then if (El.Parent is TPasProcedure) and (TPasProcedure(El.Parent).ProcType=El) then
begin begin
@ -3281,15 +3302,21 @@ begin
end; end;
if Proc.IsExternal then if Proc.IsExternal then
begin
for pm in TProcedureModifier do for pm in TProcedureModifier do
if (pm in Proc.Modifiers) if (pm in Proc.Modifiers)
and not (pm in [pmVirtual, pmDynamic, pmOverride, and not (pm in [pmVirtual, pmDynamic, pmOverride,
pmOverload, pmMessage, pmReintroduce, pmOverload, pmMessage, pmReintroduce,
pmStatic, pmVarargs,
pmExternal, pmDispId, pmExternal, pmDispId,
pmfar]) then pmfar]) then
RaiseMsg(20170216151616,nInvalidXModifierY, RaiseMsg(20170216151616,nInvalidXModifierY,
sInvalidXModifierY,[Proc.ElementTypeName,'external, '+ModifierNames[pm]],Proc); sInvalidXModifierY,[Proc.ElementTypeName,'external, '+ModifierNames[pm]],Proc);
for ptm in TProcTypeModifier do
if (ptm in Proc.ProcType.Modifiers)
and not (ptm in [ptmOfObject,ptmIsNested,ptmStatic,ptmVarargs]) then
RaiseMsg(20170411171224,nInvalidXModifierY,
sInvalidXModifierY,[Proc.ElementTypeName,'external, '+ProcTypeModifiers[ptm]],Proc);
end;
if Proc.Parent is TPasClassType then if Proc.Parent is TPasClassType then
begin begin
@ -3597,19 +3624,25 @@ begin
end; end;
procedure TPasResolver.FinishDeclaration(El: TPasElement); procedure TPasResolver.FinishDeclaration(El: TPasElement);
var
C: TClass;
begin begin
if El.ClassType=TPasVariable then C:=El.ClassType;
if C=TPasVariable then
FinishVariable(TPasVariable(El)) FinishVariable(TPasVariable(El))
else if El.ClassType=TPasProperty then else if C=TPasProperty then
FinishPropertyOfClass(TPasProperty(El)) FinishPropertyOfClass(TPasProperty(El))
else if El.ClassType=TPasArgument then else if C=TPasArgument then
FinishArgument(TPasArgument(El)); FinishArgument(TPasArgument(El));
end; end;
procedure TPasResolver.FinishVariable(El: TPasVariable); procedure TPasResolver.FinishVariable(El: TPasVariable);
begin begin
if (El.Visibility=visPublished) then if (El.Visibility=visPublished) then
RaiseMsg(20170403223837,nSymbolCannotBePublished,sSymbolCannotBePublished,[],El); begin
if [vmClass,vmStatic,vmCVar]*El.VarModifiers<>[] then
RaiseMsg(20170403223837,nSymbolCannotBePublished,sSymbolCannotBePublished,[],El);
end;
if El.Expr<>nil then if El.Expr<>nil then
begin begin
ResolveExpr(El.Expr,rraRead); ResolveExpr(El.Expr,rraRead);
@ -3757,7 +3790,7 @@ var
end; end;
var var
ResultType: TPasType; ResultType, TypeEl: TPasType;
CurClassType: TPasClassType; CurClassType: TPasClassType;
AccEl: TPasElement; AccEl: TPasElement;
Proc: TPasProcedure; Proc: TPasProcedure;
@ -3788,7 +3821,7 @@ begin
begin begin
// check compatibility // check compatibility
AccEl:=GetAccessor(PropEl.ReadAccessor); AccEl:=GetAccessor(PropEl.ReadAccessor);
if AccEl is TPasVariable then if (AccEl.ClassType=TPasVariable) or (AccEl.ClassType=TPasConst) then
begin begin
if PropEl.Args.Count>0 then if PropEl.Args.Count>0 then
RaiseXExpectedButYFound(20170216151823,'function',AccEl.ElementTypeName,PropEl.ReadAccessor); RaiseXExpectedButYFound(20170216151823,'function',AccEl.ElementTypeName,PropEl.ReadAccessor);
@ -3838,7 +3871,7 @@ begin
begin begin
// check compatibility // check compatibility
AccEl:=GetAccessor(PropEl.WriteAccessor); AccEl:=GetAccessor(PropEl.WriteAccessor);
if AccEl is TPasVariable then if AccEl.ClassType=TPasVariable then
begin begin
if PropEl.Args.Count>0 then if PropEl.Args.Count>0 then
RaiseXExpectedButYFound(20170216151852,'procedure',AccEl.ElementTypeName,PropEl.WriteAccessor); RaiseXExpectedButYFound(20170216151852,'procedure',AccEl.ElementTypeName,PropEl.WriteAccessor);
@ -3892,13 +3925,27 @@ begin
begin begin
ResolveExpr(PropEl.ImplementsFunc,rraRead); ResolveExpr(PropEl.ImplementsFunc,rraRead);
// ToDo: check compatibility // ToDo: check compatibility
RaiseNotYetImplemented(20170409213850,PropEl.ImplementsFunc);
end; end;
if PropEl.StoredAccessor<>nil then if PropEl.StoredAccessor<>nil then
begin begin
// check compatibility // check compatibility
AccEl:=GetAccessor(PropEl.StoredAccessor); AccEl:=GetAccessor(PropEl.StoredAccessor);
if AccEl is TPasProcedure then if (AccEl.ClassType=TPasVariable) or (AccEl.ClassType=TPasConst) then
begin
if PropEl.IndexExpr<>nil then
RaiseNotYetImplemented(20170409214006,PropEl.StoredAccessor,'stored with index');
TypeEl:=ResolveAliasType(TPasVariable(AccEl).VarType);
if not IsBaseType(TypeEl,btBoolean) then
RaiseIncompatibleType(20170409214300,nIncompatibleTypesGotExpected,
[],TypeEl,BaseTypes[btBoolean],PropEl.StoredAccessor);
if (vmClass in PropEl.VarModifiers)<>(vmClass in TPasVariable(AccEl).VarModifiers) then
if vmClass in PropEl.VarModifiers then
RaiseXExpectedButYFound(20170409214351,'class var','var',PropEl.StoredAccessor)
else
RaiseXExpectedButYFound(20170409214359,'var','class var',PropEl.StoredAccessor);
end
else if AccEl is TPasProcedure then
begin begin
// check function // check function
Proc:=TPasProcedure(AccEl); Proc:=TPasProcedure(AccEl);
@ -4913,9 +4960,7 @@ var
C: TClass; C: TClass;
begin begin
Value:=Params.Value; Value:=Params.Value;
if (Value.ClassType=TSelfExpr) if IsNameExpr(Value) then
or ((Value.ClassType=TPrimitiveExpr)
and (TPrimitiveExpr(Value).Kind=pekIdent)) then
begin begin
// e.g. Name() -> find compatible // e.g. Name() -> find compatible
if Value.ClassType=TPrimitiveExpr then if Value.ClassType=TPrimitiveExpr then
@ -7494,6 +7539,51 @@ begin
AccessExpr(P[2],rraRead); AccessExpr(P[2],rraRead);
end; end;
function TPasResolver.BI_TypeInfo_OnGetCallCompatibility(
Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
var
Params: TParamsExpr;
Param: TPasExpr;
Decl: TPasElement;
ParamResolved: TPasResolverResult;
aType: TPasType;
begin
Result:=cIncompatible;
if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
exit;
Params:=TParamsExpr(Expr);
// check type or var
Param:=Params.Params[0];
ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
Decl:=ParamResolved.IdentEl;
aType:=nil;
if (Decl<>nil) then
begin
if Decl is TPasType then
aType:=TPasType(Decl)
else if Decl is TPasVariable then
aType:=TPasVariable(Decl).VarType
else if Decl is TPasArgument then
aType:=TPasArgument(Decl).ArgType;
end;
if aType=nil then
RaiseMsg(20170411100259,nTypeIdentifierExpected,sTypeIdentifierExpected,[],Param);
aType:=ResolveAliasType(aType);
if not HasTypeInfo(aType) then
RaiseMsg(20170413200118,nSymbolCannotBePublished,sSymbolCannotBePublished,[],Param);
Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
end;
procedure TPasResolver.BI_TypeInfo_OnGetCallResult(Proc: TResElDataBuiltInProc;
Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
begin
if Proc=nil then;
if Params=nil then ;
SetResolverTypeExpr(ResolvedEl,btPointer,FBaseTypes[btPointer],[rrfReadable]);
end;
constructor TPasResolver.Create; constructor TPasResolver.Create;
begin begin
inherited Create; inherited Create;
@ -7807,8 +7897,10 @@ begin
and (vmClass in TPasVariable(FindData.Found).VarModifiers) then and (vmClass in TPasVariable(FindData.Found).VarModifiers) then
// class var/const/property: ok // class var/const/property: ok
else else
RaiseMsg(20170216152348,nCannotAccessThisMemberFromAClassReference, begin
sCannotAccessThisMemberFromAClassReference,[],FindData.ErrorPosEl); RaiseMsg(20170216152348,nCannotAccessThisMemberFromAX,
sCannotAccessThisMemberFromAX,[FindData.Found.Parent.ElementTypeName],FindData.ErrorPosEl);
end;
end end
else if (proExtClassInstanceNoTypeMembers in Options) else if (proExtClassInstanceNoTypeMembers in Options)
and (StartScope.ClassType=TPasDotClassScope) and (StartScope.ClassType=TPasDotClassScope)
@ -8126,6 +8218,10 @@ begin
AddBuiltInProc('Delete','procedure Delete(var Array; Start, Count: integer)', AddBuiltInProc('Delete','procedure Delete(var Array; Start, Count: integer)',
@BI_DeleteArray_OnGetCallCompatibility,nil, @BI_DeleteArray_OnGetCallCompatibility,nil,
@BI_DeleteArray_OnFinishParamsExpr,bfDeleteArray,[bipfCanBeStatement]); @BI_DeleteArray_OnFinishParamsExpr,bfDeleteArray,[bipfCanBeStatement]);
if bfTypeInfo in TheBaseProcs then
AddBuiltInProc('TypeInfo','function TypeInfo(type or var identifier): Pointer',
@BI_TypeInfo_OnGetCallCompatibility,@BI_TypeInfo_OnGetCallResult,
nil,bfTypeInfo);
end; end;
function TPasResolver.AddBaseType(const aName: string; Typ: TResolverBaseType function TPasResolver.AddBaseType(const aName: string; Typ: TResolverBaseType
@ -8683,8 +8779,7 @@ begin
end end
else else
begin begin
IsVarArgs:=IsVarArgs or ((ProcType.Parent is TPasProcedure) IsVarArgs:=IsVarArgs or (ptmVarargs in ProcType.Modifiers);
and (pmVarargs in TPasProcedure(ProcType.Parent).Modifiers));
if IsVarArgs then if IsVarArgs then
begin begin
ComputeElement(Param,ParamResolved,[],Param); ComputeElement(Param,ParamResolved,[],Param);
@ -9049,6 +9144,7 @@ function TPasResolver.CheckAssignResCompatibility(const LHS,
var var
TypeEl: TPasType; TypeEl: TPasType;
Handled: Boolean; Handled: Boolean;
C: TClass;
begin begin
// check if the RHS can be converted to LHS // check if the RHS can be converted to LHS
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
@ -9118,10 +9214,11 @@ begin
else if LHS.BaseType=btContext then else if LHS.BaseType=btContext then
begin begin
TypeEl:=LHS.TypeEl; TypeEl:=LHS.TypeEl;
if (TypeEl.ClassType=TPasClassType) C:=TypeEl.ClassType;
or (TypeEl.ClassType=TPasClassOfType) if (C=TPasClassType)
or (TypeEl.ClassType=TPasPointerType) or (C=TPasClassOfType)
or (TypeEl is TPasProcedureType) or (C=TPasPointerType)
or C.InheritsFrom(TPasProcedureType)
or IsDynArray(TypeEl) then or IsDynArray(TypeEl) then
Result:=cExact; Result:=cExact;
end; end;
@ -9154,6 +9251,36 @@ begin
Result:=cExact; Result:=cExact;
end; end;
end end
else if LHS.BaseType=btPointer then
begin
if RHS.BaseType=btPointer then
begin
if IsBaseType(LHS.TypeEl,btPointer) then
Result:=cExact // btPointer can take any pointer
else if IsBaseType(RHS.TypeEl,btPointer) then
Result:=cExact+1 // any pointer can take a btPointer
else if IsSameType(LHS.TypeEl,RHS.TypeEl) then
Result:=cExact // pointer of same type
else if (LHS.TypeEl<>nil) and (RHS.TypeEl<>nil) then
Result:=CheckAssignCompatibility(LHS.TypeEl,RHS.TypeEl,RaiseOnIncompatible);
end
else if IsBaseType(LHS.TypeEl,btPointer) then
begin
if RHS.BaseType=btContext then
begin
C:=RHS.TypeEl.ClassType;
if C=TPasClassType then
exit(cExact) // class type or class instance
else if C=TPasClassOfType then
Result:=cExact
else if C=TPasArrayType then
begin
if IsDynArray(RHS.TypeEl) then
Result:=cExact;
end;
end;
end;
end
else if (LHS.BaseType=btContext) and (LHS.TypeEl is TPasArrayType) then else if (LHS.BaseType=btContext) and (LHS.TypeEl is TPasArrayType) then
Result:=CheckAssignCompatibilityArrayType(LHS,RHS,ErrorEl,RaiseOnIncompatible); Result:=CheckAssignCompatibilityArrayType(LHS,RHS,ErrorEl,RaiseOnIncompatible);
end; end;
@ -9475,6 +9602,24 @@ begin
end; end;
end; end;
function TPasResolver.GetPasPropertyStored(El: TPasProperty): TPasElement;
// search the member variable or setter procedure of a property
var
DeclEl: TPasElement;
begin
Result:=nil;
while El<>nil do
begin
if El.StoredAccessor<>nil then
begin
DeclEl:=(El.StoredAccessor.CustomData as TResolvedReference).Declaration;
Result:=DeclEl;
exit;
end;
El:=GetPasPropertyAncestor(El);
end;
end;
function TPasResolver.CheckParamCompatibility(Expr: TPasExpr; function TPasResolver.CheckParamCompatibility(Expr: TPasExpr;
Param: TPasArgument; ParamNo: integer; RaiseOnError: boolean): integer; Param: TPasArgument; ParamNo: integer; RaiseOnError: boolean): integer;
var var
@ -10021,33 +10166,52 @@ begin
begin begin
if FromResolved.BaseType in btAllStringAndChars then if FromResolved.BaseType in btAllStringAndChars then
Result:=cExact+1; Result:=cExact+1;
end
else if ToTypeBaseType=btPointer then
begin
if FromResolved.BaseType=btPointer then
Result:=cExact
else if FromResolved.BaseType=btContext then
begin
C:=FromResolved.TypeEl.ClassType;
if (C=TPasClassType)
or (C=TPasClassOfType)
or (C=TPasPointerType)
or ((C=TPasArrayType) and IsDynArray(FromResolved.TypeEl)) then
Result:=cExact;
end;
end; end;
end; end;
end end
else if C=TPasClassType then else if C=TPasClassType then
begin begin
// to class // to class
if FromResolved.BaseType=btNil then if FromResolved.BaseType=btContext then
Result:=cExact
else if (FromResolved.BaseType=btContext)
and (FromResolved.TypeEl.ClassType=TPasClassType) then
begin begin
if (FromResolved.IdentEl is TPasType) then if FromResolved.TypeEl.ClassType=TPasClassType then
RaiseMsg(20170404162606,nCannotTypecastAType,sCannotTypecastAType,[],ErrorEl); begin
// type cast upwards or downwards if FromResolved.IdentEl is TPasType then
Result:=CheckSrcIsADstType(FromResolved,ToResolved,ErrorEl); RaiseMsg(20170404162606,nCannotTypecastAType,sCannotTypecastAType,[],ErrorEl);
if Result=cIncompatible then // type cast upwards or downwards
Result:=CheckSrcIsADstType(ToResolved,FromResolved,ErrorEl); Result:=CheckSrcIsADstType(FromResolved,ToResolved,ErrorEl);
if Result=cIncompatible then if Result=cIncompatible then
Result:=CheckTypeCastClassInstanceToClass(FromResolved,ToResolved,ErrorEl); Result:=CheckSrcIsADstType(ToResolved,FromResolved,ErrorEl);
if Result=cIncompatible then
Result:=CheckTypeCastClassInstanceToClass(FromResolved,ToResolved,ErrorEl);
end
end
else if FromResolved.BaseType=btPointer then
begin
if IsBaseType(FromResolved.TypeEl,btPointer) then
Result:=cExact; // untyped pointer to class instance
end; end;
end end
else if C=TPasClassOfType then else if C=TPasClassOfType then
begin begin
//writeln('TPasResolver.CheckTypeCast class-of FromRes.TypeEl=',GetObjName(FromResolved.TypeEl),' FromRes.IdentEl=',GetObjName(FromResolved.IdentEl)); //writeln('TPasResolver.CheckTypeCast class-of FromRes.TypeEl=',GetObjName(FromResolved.TypeEl),' FromRes.IdentEl=',GetObjName(FromResolved.IdentEl));
if (FromResolved.BaseType=btContext) then if FromResolved.BaseType=btContext then
begin begin
if (FromResolved.TypeEl.ClassType=TPasClassOfType) then if FromResolved.TypeEl.ClassType=TPasClassOfType then
begin begin
if (FromResolved.IdentEl is TPasType) then if (FromResolved.IdentEl is TPasType) then
RaiseMsg(20170404162604,nCannotTypecastAType,sCannotTypecastAType,[],ErrorEl); RaiseMsg(20170404162604,nCannotTypecastAType,sCannotTypecastAType,[],ErrorEl);
@ -10056,6 +10220,11 @@ begin
FromClassType:=TPasClassOfType(FromResolved.TypeEl).DestType; FromClassType:=TPasClassOfType(FromResolved.TypeEl).DestType;
Result:=CheckClassesAreRelated(ToClassType,FromClassType,ErrorEl); Result:=CheckClassesAreRelated(ToClassType,FromClassType,ErrorEl);
end; end;
end
else if FromResolved.BaseType=btPointer then
begin
if IsBaseType(FromResolved.TypeEl,btPointer) then
Result:=cExact; // untyped pointer to class-of
end; end;
end end
else if C=TPasEnumType then else if C=TPasEnumType then
@ -10065,10 +10234,18 @@ begin
end end
else if C=TPasArrayType then else if C=TPasArrayType then
begin begin
if (FromResolved.BaseType=btContext) if FromResolved.BaseType=btContext then
and (FromResolved.TypeEl.ClassType=TPasArrayType) then begin
Result:=CheckTypeCastArray(TPasArrayType(FromResolved.TypeEl), if FromResolved.TypeEl.ClassType=TPasArrayType then
TPasArrayType(ToTypeEl),ErrorEl,RaiseOnError); Result:=CheckTypeCastArray(TPasArrayType(FromResolved.TypeEl),
TPasArrayType(ToTypeEl),ErrorEl,RaiseOnError);
end
else if FromResolved.BaseType=btPointer then
begin
if IsDynArray(ToResolved.TypeEl)
and IsBaseType(FromResolved.TypeEl,btPointer) then
Result:=cExact; // untyped pointer to dynnamic array
end;
end; end;
end end
else if ToTypeEl<>nil then else if ToTypeEl<>nil then
@ -10595,11 +10772,21 @@ begin
end; end;
function TPasResolver.ResolveAliasType(aType: TPasType): TPasType; function TPasResolver.ResolveAliasType(aType: TPasType): TPasType;
var
C: TClass;
begin begin
Result:=aType; Result:=aType;
while (Result<>nil) while Result<>nil do
and ((Result.ClassType=TPasAliasType) or (Result.ClassType=TPasTypeAliasType)) do begin
Result:=TPasAliasType(Result).DestType; C:=Result.ClassType;
if (C=TPasAliasType) or (C=TPasTypeAliasType) then
Result:=TPasAliasType(Result).DestType
else if (C=TPasClassType) and TPasClassType(Result).IsForward
and (Result.CustomData is TResolvedReference) then
Result:=TResolvedReference(Result.CustomData).Declaration as TPasType
else
exit;
end;
end; end;
function TPasResolver.ExprIsAddrTarget(El: TPasExpr): boolean; function TPasResolver.ExprIsAddrTarget(El: TPasExpr): boolean;
@ -10615,8 +10802,7 @@ var
begin begin
Result:=false; Result:=false;
if El=nil then exit; if El=nil then exit;
if not ((El.ClassType=TParamsExpr) or (El.ClassType=TPrimitiveExpr) if not IsNameExpr(El) then
or (El.ClassType=TSelfExpr)) then
exit; exit;
repeat repeat
Parent:=El.Parent; Parent:=El.Parent;
@ -10793,8 +10979,7 @@ begin
Result:=false; Result:=false;
if (Params=nil) or (Params.Kind<>pekFuncParams) then exit; if (Params=nil) or (Params.Kind<>pekFuncParams) then exit;
Value:=Params.Value; Value:=Params.Value;
if (Value.ClassType<>TSelfExpr) if not IsNameExpr(Value) then
and ((Value.ClassType<>TPrimitiveExpr) or (TPrimitiveExpr(Value).Kind<>pekIdent)) then
exit; exit;
if not (Value.CustomData is TResolvedReference) then exit; if not (Value.CustomData is TResolvedReference) then exit;
Ref:=TResolvedReference(Value.CustomData); Ref:=TResolvedReference(Value.CustomData);
@ -10828,6 +11013,18 @@ begin
Result:=2; Result:=2;
end; end;
function TPasResolver.HasTypeInfo(El: TPasType): boolean;
begin
Result:=false;
if El=nil then exit;
if El.CustomData is TResElDataBaseType then
exit(true); // base type
if El.Parent=nil then exit;
if (El.Parent is TPasType) and not HasTypeInfo(TPasType(El.Parent)) then
exit;
Result:=true;
end;
function TPasResolver.CheckSrcIsADstType(const ResolvedSrcType, function TPasResolver.CheckSrcIsADstType(const ResolvedSrcType,
ResolvedDestType: TPasResolverResult; ErrorEl: TPasElement): integer; ResolvedDestType: TPasResolverResult; ErrorEl: TPasElement): integer;
// finds distance between classes SrcType and DestType // finds distance between classes SrcType and DestType