mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-12 20:31:15 +02:00
* Patch from Mattias Gaertner: type cast array to array with same dimensions and element types
git-svn-id: trunk@35695 -
This commit is contained in:
michael
parent
92cca391aa
commit
03e6268a3d
@ -111,6 +111,7 @@ Works:
|
||||
- multi dimensional
|
||||
- const
|
||||
- open array, override, pass array literal, pass var
|
||||
- type cast array to arrays with same dimensions and compatible element type
|
||||
- check if var initexpr fits vartype: var a: type = expr;
|
||||
- built-in functions high, low for range types
|
||||
- procedure type
|
||||
@ -425,9 +426,9 @@ const
|
||||
'Nil',
|
||||
'Procedure/Function',
|
||||
'BuiltInProc',
|
||||
'set-[]',
|
||||
'set literal',
|
||||
'range..',
|
||||
'const-array-(,)'
|
||||
'array literal'
|
||||
);
|
||||
|
||||
type
|
||||
@ -1080,8 +1081,9 @@ type
|
||||
out ResolvedEl: TPasResolverResult; Flags: TPasResolverComputeFlags;
|
||||
StartEl: TPasElement);
|
||||
procedure CheckIsClass(El: TPasElement; const ResolvedEl: TPasResolverResult);
|
||||
function CheckTypeCastClassInstanceToClass(Param: TPasExpr;
|
||||
const FromClassRes, ToClassRes: TPasResolverResult): integer; virtual;
|
||||
function CheckTypeCastClassInstanceToClass(
|
||||
const FromClassRes, ToClassRes: TPasResolverResult;
|
||||
ErrorEl: TPasElement): integer; virtual;
|
||||
procedure CheckRangeExpr(Left, Right: TPasExpr;
|
||||
out LeftResolved, RightResolved: TPasResolverResult);
|
||||
procedure CheckSetElementsCompatible(Left, Right: TPasExpr;
|
||||
@ -1097,11 +1099,9 @@ type
|
||||
function CheckRaiseTypeArgNo(id: int64; ArgNo: integer; Param: TPasExpr;
|
||||
const ParamResolved: TPasResolverResult; Expected: string; RaiseOnError: boolean): integer;
|
||||
// custom types (added by descendant resolvers)
|
||||
function CheckTypeCastCustomBaseType(const TypeResolved: TPasResolverResult;
|
||||
Param: TPasExpr; const ParamResolved: TPasResolverResult): integer; virtual;
|
||||
function CheckAssignCompatibilityCustomBaseType(
|
||||
function CheckAssignCompatibilityCustom(
|
||||
const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement;
|
||||
RaiseOnIncompatible: boolean): integer; virtual;
|
||||
RaiseOnIncompatible: boolean; var Handled: boolean): integer; virtual;
|
||||
function CheckEqualCompatibilityCustomType(
|
||||
const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement;
|
||||
RaiseOnIncompatible: boolean): integer; virtual;
|
||||
@ -1282,6 +1282,10 @@ type
|
||||
const TypeA, TypeB: TPasResolverResult; ErrorEl: TPasElement;
|
||||
RaiseOnIncompatible: boolean): integer;
|
||||
function CheckTypeCast(El: TPasType; Params: TParamsExpr; RaiseOnError: boolean): integer;
|
||||
function CheckTypeCastRes(const FromResolved, ToResolved: TPasResolverResult;
|
||||
ErrorEl: TPasElement; RaiseOnError: boolean): integer; virtual;
|
||||
function CheckTypeCastArray(FromType, ToType: TPasArrayType;
|
||||
ErrorEl: TPasElement; RaiseOnError: boolean): integer;
|
||||
function CheckSrcIsADstType(
|
||||
const ResolvedSrcType, ResolvedDestType: TPasResolverResult;
|
||||
ErrorEl: TPasElement): integer;
|
||||
@ -2536,6 +2540,7 @@ var
|
||||
BuiltInProc: TResElDataBuiltInProc;
|
||||
CandidateFound: Boolean;
|
||||
VarType, TypeEl: TPasType;
|
||||
C: TClass;
|
||||
begin
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.OnFindCallElements START ---------');
|
||||
@ -2596,7 +2601,8 @@ begin
|
||||
else if El is TPasType then
|
||||
begin
|
||||
TypeEl:=ResolveAliasType(TPasType(El));
|
||||
if TypeEl.ClassType=TPasUnresolvedSymbolRef then
|
||||
C:=TypeEl.ClassType;
|
||||
if C=TPasUnresolvedSymbolRef then
|
||||
begin
|
||||
if TypeEl.CustomData.ClassType=TResElDataBuiltInProc then
|
||||
begin
|
||||
@ -2630,36 +2636,17 @@ begin
|
||||
CandidateFound:=true;
|
||||
end;
|
||||
end
|
||||
else if TypeEl.ClassType=TPasClassType then
|
||||
else if (C=TPasClassType)
|
||||
or (C=TPasClassOfType)
|
||||
or (C=TPasEnumType)
|
||||
or (C=TPasArrayType) then
|
||||
begin
|
||||
// type cast to a class
|
||||
// type cast to a class, class-of, enum, or array
|
||||
Abort:=true; // can't be overloaded
|
||||
if Data^.Found<>nil then exit;
|
||||
Distance:=CheckTypeCast(TPasType(El),Data^.Params,false);
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.OnFindCallElements type cast to class=',El.Name,' Distance=',Distance);
|
||||
{$ENDIF}
|
||||
CandidateFound:=true;
|
||||
end
|
||||
else if TypeEl.ClassType=TPasClassOfType then
|
||||
begin
|
||||
// type cast to a class-of
|
||||
Abort:=true; // can't be overloaded
|
||||
if Data^.Found<>nil then exit;
|
||||
Distance:=CheckTypeCast(TPasType(El),Data^.Params,false);
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.OnFindCallElements type cast to class-of=',El.Name,' Distance=',Distance);
|
||||
{$ENDIF}
|
||||
CandidateFound:=true;
|
||||
end
|
||||
else if TypeEl.ClassType=TPasEnumType then
|
||||
begin
|
||||
// type cast to a enum
|
||||
Abort:=true; // can't be overloaded
|
||||
if Data^.Found<>nil then exit;
|
||||
Distance:=cExact;
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.OnFindCallElements type cast to enum=',El.Name,' Distance=',Distance);
|
||||
writeln('TPasResolver.OnFindCallElements type cast to =',GetObjName(El),' Distance=',Distance);
|
||||
{$ENDIF}
|
||||
CandidateFound:=true;
|
||||
end;
|
||||
@ -4850,6 +4837,7 @@ var
|
||||
ResolvedEl: TPasResolverResult;
|
||||
Value: TPasExpr;
|
||||
TypeEl: TPasType;
|
||||
C: TClass;
|
||||
begin
|
||||
Value:=Params.Value;
|
||||
if (Value.ClassType=TSelfExpr)
|
||||
@ -4940,15 +4928,17 @@ begin
|
||||
else if FoundEl is TPasType then
|
||||
begin
|
||||
TypeEl:=ResolveAliasType(TPasType(FoundEl));
|
||||
if (TypeEl.ClassType=TPasClassType)
|
||||
or (TypeEl.ClassType=TPasClassOfType)
|
||||
or (TypeEl.ClassType=TPasEnumType) then
|
||||
C:=TypeEl.ClassType;
|
||||
if (C=TPasClassType)
|
||||
or (C=TPasClassOfType)
|
||||
or (C=TPasEnumType)
|
||||
or (C=TPasArrayType) then
|
||||
begin
|
||||
// type cast
|
||||
for i:=0 to length(Params.Params)-1 do
|
||||
FinishParamExpressionAccess(Params.Params[i],Access);
|
||||
end
|
||||
else if TypeEl.ClassType=TPasUnresolvedSymbolRef then
|
||||
else if C=TPasUnresolvedSymbolRef then
|
||||
begin
|
||||
if TypeEl.CustomData is TResElDataBuiltInProc then
|
||||
begin
|
||||
@ -6234,13 +6224,13 @@ begin
|
||||
['class',ResolvedEl.TypeEl.ElementTypeName],El);
|
||||
end;
|
||||
|
||||
function TPasResolver.CheckTypeCastClassInstanceToClass(Param: TPasExpr;
|
||||
const FromClassRes, ToClassRes: TPasResolverResult): integer;
|
||||
function TPasResolver.CheckTypeCastClassInstanceToClass(const FromClassRes,
|
||||
ToClassRes: TPasResolverResult; ErrorEl: TPasElement): integer;
|
||||
// called when type casting a class instance into an unrelated class
|
||||
begin
|
||||
if Param=nil then ;
|
||||
if FromClassRes.BaseType=btNone then ;
|
||||
if ToClassRes.BaseType=btNone then ;
|
||||
if ErrorEl=nil then ;
|
||||
Result:=cIncompatible;
|
||||
end;
|
||||
|
||||
@ -6397,19 +6387,9 @@ begin
|
||||
Result:=cIncompatible;
|
||||
end;
|
||||
|
||||
function TPasResolver.CheckTypeCastCustomBaseType(
|
||||
const TypeResolved: TPasResolverResult; Param: TPasExpr;
|
||||
const ParamResolved: TPasResolverResult): integer;
|
||||
begin
|
||||
if TypeResolved.BaseType=btNone then ;
|
||||
if Param=nil then ;
|
||||
if ParamResolved.BaseType=btNone then ;
|
||||
Result:=cIncompatible;
|
||||
end;
|
||||
|
||||
function TPasResolver.CheckAssignCompatibilityCustomBaseType(const LHS,
|
||||
RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean
|
||||
): integer;
|
||||
function TPasResolver.CheckAssignCompatibilityCustom(const LHS,
|
||||
RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean;
|
||||
var Handled: boolean): integer;
|
||||
// called when LHS or RHS BaseType is btCustom
|
||||
// if RaiseOnIncompatible=true you can raise an useful error.
|
||||
begin
|
||||
@ -6418,6 +6398,7 @@ begin
|
||||
if RHS.BaseType=btNone then ;
|
||||
if ErrorEl=nil then ;
|
||||
if RaiseOnIncompatible then ;
|
||||
if Handled then ;
|
||||
end;
|
||||
|
||||
function TPasResolver.CheckEqualCompatibilityCustomType(const LHS,
|
||||
@ -8365,7 +8346,25 @@ procedure TPasResolver.RaiseIncompatibleTypeRes(id: int64; MsgNumber: integer;
|
||||
var
|
||||
DescA, DescB: String;
|
||||
begin
|
||||
if (TypeA.TypeEl<>nil) and (TypeB.TypeEl<>nil) then
|
||||
if TypeA.BaseType<>TypeB.BaseType then
|
||||
begin
|
||||
if TypeA.BaseType=btContext then
|
||||
DescA:=GetTypeDesc(TypeA.TypeEl)
|
||||
else
|
||||
DescA:=BaseTypeNames[TypeA.BaseType];
|
||||
if TypeB.BaseType=btContext then
|
||||
DescB:=GetTypeDesc(TypeB.TypeEl)
|
||||
else
|
||||
DescB:=BaseTypeNames[TypeB.BaseType];
|
||||
if DescA=DescB then
|
||||
begin
|
||||
if TypeA.BaseType=btContext then
|
||||
DescA:=GetTypeDesc(TypeA.TypeEl,true);
|
||||
if TypeB.BaseType=btContext then
|
||||
DescB:=GetTypeDesc(TypeB.TypeEl,true);
|
||||
end;
|
||||
end
|
||||
else if (TypeA.TypeEl<>nil) and (TypeB.TypeEl<>nil) then
|
||||
begin
|
||||
DescA:=GetTypeDesc(TypeA.TypeEl);
|
||||
DescB:=GetTypeDesc(TypeB.TypeEl);
|
||||
@ -8669,12 +8668,10 @@ begin
|
||||
or (Arg1Resolved.TypeEl=nil)
|
||||
or (Arg2Resolved.TypeEl=nil) then
|
||||
exit(false);
|
||||
if Arg1Resolved.TypeEl=Arg2Resolved.TypeEl then
|
||||
if (Arg1Resolved.BaseType=Arg2Resolved.BaseType)
|
||||
and IsSameType(Arg1Resolved.TypeEl,Arg2Resolved.TypeEl) then
|
||||
exit(true);
|
||||
C:=Arg1Resolved.TypeEl.ClassType;
|
||||
if (C=TPasUnresolvedSymbolRef)
|
||||
and (IsBaseType(Arg2Resolved.TypeEl,Arg1Resolved.BaseType)) then
|
||||
exit(true);
|
||||
if (C=TPasArrayType) and (Arg2Resolved.TypeEl.ClassType=TPasArrayType) then
|
||||
begin
|
||||
Arr1:=TPasArrayType(Arg1Resolved.TypeEl);
|
||||
@ -8745,6 +8742,7 @@ function TPasResolver.CheckAssignResCompatibility(const LHS,
|
||||
): integer;
|
||||
var
|
||||
TypeEl: TPasType;
|
||||
Handled: Boolean;
|
||||
begin
|
||||
// check if the RHS can be converted to LHS
|
||||
{$IFDEF VerbosePasResolver}
|
||||
@ -8752,100 +8750,103 @@ begin
|
||||
{$ENDIF}
|
||||
Result:=-1;
|
||||
|
||||
if LHS.TypeEl=nil then
|
||||
Handled:=false;
|
||||
Result:=CheckAssignCompatibilityCustom(LHS,RHS,ErrorEl,RaiseOnIncompatible,Handled);
|
||||
if not Handled then
|
||||
begin
|
||||
if LHS.BaseType=btUntyped then
|
||||
if LHS.TypeEl=nil then
|
||||
begin
|
||||
// untyped parameter
|
||||
Result:=cExact+1;
|
||||
if LHS.BaseType=btUntyped then
|
||||
begin
|
||||
// untyped parameter
|
||||
Result:=cExact+1;
|
||||
end
|
||||
else
|
||||
RaiseNotYetImplemented(20160922163631,LHS.IdentEl);
|
||||
end
|
||||
else
|
||||
RaiseNotYetImplemented(20160922163631,LHS.IdentEl);
|
||||
end
|
||||
else if (LHS.BaseType=btCustom) or (RHS.BaseType=btCustom) then
|
||||
Result:=CheckAssignCompatibilityCustomBaseType(LHS,RHS,ErrorEl,RaiseOnIncompatible)
|
||||
else if LHS.BaseType=RHS.BaseType then
|
||||
begin
|
||||
if LHS.BaseType=btContext then
|
||||
Result:=CheckAssignCompatibilityUserType(LHS,RHS,ErrorEl,RaiseOnIncompatible)
|
||||
else
|
||||
Result:=cExact; // same base type, maybe not same type name (e.g. longint and integer)
|
||||
end
|
||||
else if (LHS.BaseType in btAllInteger)
|
||||
and (RHS.BaseType in btAllInteger) then
|
||||
Result:=cExact+1
|
||||
else if (LHS.BaseType in btAllBooleans)
|
||||
and (RHS.BaseType in btAllBooleans) then
|
||||
Result:=cExact+1
|
||||
else if (LHS.BaseType in btAllStringAndChars)
|
||||
and (RHS.BaseType in btAllStringAndChars) then
|
||||
Result:=cExact+1
|
||||
else if (LHS.BaseType in btAllFloats)
|
||||
and (RHS.BaseType in btAllFloats+btAllInteger) then
|
||||
Result:=cExact+1
|
||||
else if LHS.BaseType=btNil then
|
||||
begin
|
||||
if RaiseOnIncompatible then
|
||||
RaiseMsg(20170216152431,nCantAssignValuesToAnAddress,sCantAssignValuesToAnAddress,
|
||||
[],ErrorEl);
|
||||
exit(cIncompatible);
|
||||
end
|
||||
else if LHS.BaseType in [btRange,btSet,btModule,btArray] then
|
||||
begin
|
||||
if RaiseOnIncompatible then
|
||||
RaiseMsg(20170216152432,nIllegalExpression,sIllegalExpression,[],ErrorEl);
|
||||
exit(cIncompatible);
|
||||
end
|
||||
else if (LHS.IdentEl=nil) and (LHS.ExprEl=nil) then
|
||||
begin
|
||||
if RaiseOnIncompatible then
|
||||
RaiseMsg(20170216152434,nIllegalExpression,sIllegalExpression,[],ErrorEl);
|
||||
exit(cIncompatible);
|
||||
end
|
||||
else if RHS.BaseType=btNil then
|
||||
begin
|
||||
if LHS.BaseType=btPointer then
|
||||
Result:=cExact
|
||||
else if LHS.BaseType=btContext then
|
||||
else if LHS.BaseType=RHS.BaseType then
|
||||
begin
|
||||
TypeEl:=LHS.TypeEl;
|
||||
if (TypeEl.ClassType=TPasClassType)
|
||||
or (TypeEl.ClassType=TPasClassOfType)
|
||||
or (TypeEl.ClassType=TPasPointerType)
|
||||
or (TypeEl is TPasProcedureType)
|
||||
or IsDynArray(TypeEl) then
|
||||
Result:=cExact;
|
||||
end;
|
||||
end
|
||||
else if RHS.BaseType=btSet then
|
||||
begin
|
||||
if (LHS.BaseType=btSet) then
|
||||
if LHS.BaseType=btContext then
|
||||
Result:=CheckAssignCompatibilityUserType(LHS,RHS,ErrorEl,RaiseOnIncompatible)
|
||||
else
|
||||
Result:=cExact; // same base type, maybe not same type name (e.g. longint and integer)
|
||||
end
|
||||
else if (LHS.BaseType in btAllInteger)
|
||||
and (RHS.BaseType in btAllInteger) then
|
||||
Result:=cExact+1
|
||||
else if (LHS.BaseType in btAllBooleans)
|
||||
and (RHS.BaseType in btAllBooleans) then
|
||||
Result:=cExact+1
|
||||
else if (LHS.BaseType in btAllStringAndChars)
|
||||
and (RHS.BaseType in btAllStringAndChars) then
|
||||
Result:=cExact+1
|
||||
else if (LHS.BaseType in btAllFloats)
|
||||
and (RHS.BaseType in btAllFloats+btAllInteger) then
|
||||
Result:=cExact+1
|
||||
else if LHS.BaseType=btNil then
|
||||
begin
|
||||
if RHS.TypeEl=nil then
|
||||
Result:=cExact // empty set
|
||||
else if (LHS.SubType=RHS.SubType) and (LHS.SubType in (btAllBooleans+btAllInteger+[btChar])) then
|
||||
if RaiseOnIncompatible then
|
||||
RaiseMsg(20170216152431,nCantAssignValuesToAnAddress,sCantAssignValuesToAnAddress,
|
||||
[],ErrorEl);
|
||||
exit(cIncompatible);
|
||||
end
|
||||
else if LHS.BaseType in [btRange,btSet,btModule,btArray] then
|
||||
begin
|
||||
if RaiseOnIncompatible then
|
||||
RaiseMsg(20170216152432,nIllegalExpression,sIllegalExpression,[],ErrorEl);
|
||||
exit(cIncompatible);
|
||||
end
|
||||
else if (LHS.IdentEl=nil) and (LHS.ExprEl=nil) then
|
||||
begin
|
||||
if RaiseOnIncompatible then
|
||||
RaiseMsg(20170216152434,nIllegalExpression,sIllegalExpression,[],ErrorEl);
|
||||
exit(cIncompatible);
|
||||
end
|
||||
else if RHS.BaseType=btNil then
|
||||
begin
|
||||
if LHS.BaseType=btPointer then
|
||||
Result:=cExact
|
||||
else if ((LHS.SubType in btAllBooleans) and (RHS.SubType in btAllBooleans))
|
||||
or ((LHS.SubType in btAllInteger) and (RHS.SubType in btAllInteger)) then
|
||||
Result:=cExact+1
|
||||
else if (LHS.SubType=btContext) and (LHS.TypeEl is TPasEnumType)
|
||||
and (LHS.TypeEl=RHS.TypeEl) then
|
||||
Result:=cExact;
|
||||
end;
|
||||
end
|
||||
else if RHS.BaseType=btProc then
|
||||
begin
|
||||
if (msDelphi in CurrentParser.CurrentModeswitches)
|
||||
and (LHS.TypeEl is TPasProcedureType)
|
||||
and (RHS.IdentEl is TPasProcedure) then
|
||||
else if LHS.BaseType=btContext then
|
||||
begin
|
||||
TypeEl:=LHS.TypeEl;
|
||||
if (TypeEl.ClassType=TPasClassType)
|
||||
or (TypeEl.ClassType=TPasClassOfType)
|
||||
or (TypeEl.ClassType=TPasPointerType)
|
||||
or (TypeEl is TPasProcedureType)
|
||||
or IsDynArray(TypeEl) then
|
||||
Result:=cExact;
|
||||
end;
|
||||
end
|
||||
else if RHS.BaseType=btSet then
|
||||
begin
|
||||
if CheckProcAssignCompatibility(TPasProcedureType(LHS.TypeEl),
|
||||
TPasProcedure(RHS.IdentEl).ProcType) then
|
||||
Result:=cExact;
|
||||
end;
|
||||
end
|
||||
else if (LHS.BaseType=btContext) and (LHS.TypeEl is TPasArrayType) then
|
||||
Result:=CheckAssignCompatibilityArrayType(LHS,RHS,ErrorEl,RaiseOnIncompatible);
|
||||
if (LHS.BaseType=btSet) then
|
||||
begin
|
||||
if RHS.TypeEl=nil then
|
||||
Result:=cExact // empty set
|
||||
else if (LHS.SubType=RHS.SubType) and (LHS.SubType in (btAllBooleans+btAllInteger+[btChar])) then
|
||||
Result:=cExact
|
||||
else if ((LHS.SubType in btAllBooleans) and (RHS.SubType in btAllBooleans))
|
||||
or ((LHS.SubType in btAllInteger) and (RHS.SubType in btAllInteger)) then
|
||||
Result:=cExact+1
|
||||
else if (LHS.SubType=btContext) and (LHS.TypeEl is TPasEnumType)
|
||||
and (LHS.TypeEl=RHS.TypeEl) then
|
||||
Result:=cExact;
|
||||
end;
|
||||
end
|
||||
else if RHS.BaseType=btProc then
|
||||
begin
|
||||
if (msDelphi in CurrentParser.CurrentModeswitches)
|
||||
and (LHS.TypeEl is TPasProcedureType)
|
||||
and (RHS.IdentEl is TPasProcedure) then
|
||||
begin
|
||||
if CheckProcAssignCompatibility(TPasProcedureType(LHS.TypeEl),
|
||||
TPasProcedure(RHS.IdentEl).ProcType) then
|
||||
Result:=cExact;
|
||||
end;
|
||||
end
|
||||
else if (LHS.BaseType=btContext) and (LHS.TypeEl is TPasArrayType) then
|
||||
Result:=CheckAssignCompatibilityArrayType(LHS,RHS,ErrorEl,RaiseOnIncompatible);
|
||||
end;
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.CheckAssignResCompatibility incompatible LHS='+GetResolverResultDesc(LHS)+' RHS='+GetResolverResultDesc(RHS));
|
||||
{$ENDIF}
|
||||
@ -9409,6 +9410,7 @@ function TPasResolver.CheckAssignCompatibilityArrayType(const LHS,
|
||||
else
|
||||
begin
|
||||
// single value
|
||||
// Note: the parser does not store the difference between (1) and 1
|
||||
if (not IsLastRange) or (Count>1) then
|
||||
RaiseMsg(20170223095307,nExpectXArrayElementsButFoundY,sExpectXArrayElementsButFoundY,
|
||||
[IntToStr(Count),'1'],ErrorEl);
|
||||
@ -9599,133 +9601,221 @@ function TPasResolver.CheckTypeCast(El: TPasType; Params: TParamsExpr;
|
||||
var
|
||||
Param: TPasExpr;
|
||||
ParamResolved, ResolvedEl: TPasResolverResult;
|
||||
ResTypeEl, ElClassType, ParamClassType: TPasType;
|
||||
TypeBaseType: TResolverBaseType;
|
||||
begin
|
||||
if length(Params.Params)<1 then
|
||||
if length(Params.Params)<>1 then
|
||||
begin
|
||||
if RaiseOnError then
|
||||
RaiseMsg(20170216152526,nWrongNumberOfParametersForTypeCast,
|
||||
sWrongNumberOfParametersForTypeCast,[El.Name],Params);
|
||||
exit(cIncompatible);
|
||||
end;
|
||||
|
||||
Param:=Params.Params[0];
|
||||
ComputeElement(Param,ParamResolved,[]);
|
||||
Result:=cIncompatible;
|
||||
ComputeElement(El,ResolvedEl,[]);
|
||||
Result:=CheckTypeCastRes(ParamResolved,ResolvedEl,Param,RaiseOnError);
|
||||
end;
|
||||
|
||||
ResTypeEl:=ResolvedEl.TypeEl;
|
||||
if (ResTypeEl<>nil)
|
||||
and (rrfReadable in ParamResolved.Flags) then
|
||||
function TPasResolver.CheckTypeCastRes(const FromResolved,
|
||||
ToResolved: TPasResolverResult; ErrorEl: TPasElement; RaiseOnError: boolean
|
||||
): integer;
|
||||
var
|
||||
ToTypeEl, ToClassType, FromClassType: TPasType;
|
||||
ToTypeBaseType: TResolverBaseType;
|
||||
C: TClass;
|
||||
begin
|
||||
Result:=cIncompatible;
|
||||
ToTypeEl:=ToResolved.TypeEl;
|
||||
if (ToTypeEl<>nil)
|
||||
and (rrfReadable in FromResolved.Flags) then
|
||||
begin
|
||||
if ParamResolved.BaseType=btUntyped then
|
||||
C:=ToTypeEl.ClassType;
|
||||
if FromResolved.BaseType=btUntyped then
|
||||
begin
|
||||
// typecast an untyped parameter
|
||||
Result:=cExact+1;
|
||||
end
|
||||
else if (ResolvedEl.BaseType=btCustom) or (ParamResolved.BaseType=btCustom) then
|
||||
Result:=CheckTypeCastCustomBaseType(ResolvedEl,Param,ParamResolved)
|
||||
else if ResTypeEl.ClassType=TPasUnresolvedSymbolRef then
|
||||
else if C=TPasUnresolvedSymbolRef then
|
||||
begin
|
||||
if ResTypeEl.CustomData is TResElDataBaseType then
|
||||
if ToTypeEl.CustomData is TResElDataBaseType then
|
||||
begin
|
||||
// base type cast, e.g. double(aninteger)
|
||||
if ResTypeEl=ParamResolved.TypeEl then
|
||||
if ToTypeEl=FromResolved.TypeEl then
|
||||
exit(cExact);
|
||||
TypeBaseType:=(ResTypeEl.CustomData as TResElDataBaseType).BaseType;
|
||||
if TypeBaseType=ParamResolved.BaseType then
|
||||
ToTypeBaseType:=(ToTypeEl.CustomData as TResElDataBaseType).BaseType;
|
||||
if ToTypeBaseType=FromResolved.BaseType then
|
||||
Result:=cExact
|
||||
else if TypeBaseType in btAllInteger then
|
||||
else if ToTypeBaseType in btAllInteger then
|
||||
begin
|
||||
if ParamResolved.BaseType in (btAllInteger+btAllBooleans) then
|
||||
if FromResolved.BaseType in (btAllInteger+btAllBooleans) then
|
||||
Result:=cExact+1;
|
||||
end
|
||||
else if TypeBaseType in btAllFloats then
|
||||
else if ToTypeBaseType in btAllFloats then
|
||||
begin
|
||||
if ParamResolved.BaseType in (btAllInteger+btAllFloats) then
|
||||
if FromResolved.BaseType in (btAllInteger+btAllFloats) then
|
||||
Result:=cExact+1;
|
||||
end
|
||||
else if TypeBaseType in btAllBooleans then
|
||||
else if ToTypeBaseType in btAllBooleans then
|
||||
begin
|
||||
if ParamResolved.BaseType in (btAllBooleans+btAllInteger) then
|
||||
if FromResolved.BaseType in (btAllBooleans+btAllInteger) then
|
||||
Result:=cExact+1;
|
||||
end
|
||||
else if TypeBaseType in btAllStrings then
|
||||
else if ToTypeBaseType in btAllStrings then
|
||||
begin
|
||||
if ParamResolved.BaseType in btAllStringAndChars then
|
||||
if FromResolved.BaseType in btAllStringAndChars then
|
||||
Result:=cExact+1;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else if ResTypeEl.ClassType=TPasClassType then
|
||||
else if C=TPasClassType then
|
||||
begin
|
||||
if ParamResolved.BaseType=btNil then
|
||||
// to class
|
||||
if FromResolved.BaseType=btNil then
|
||||
Result:=cExact
|
||||
else if (ParamResolved.BaseType=btContext)
|
||||
and (ParamResolved.TypeEl.ClassType=TPasClassType)
|
||||
and (not (ParamResolved.IdentEl is TPasType)) then
|
||||
else if (FromResolved.BaseType=btContext)
|
||||
and (FromResolved.TypeEl.ClassType=TPasClassType)
|
||||
and (not (FromResolved.IdentEl is TPasType)) then
|
||||
begin
|
||||
// type cast upwards or downwards
|
||||
Result:=CheckSrcIsADstType(ResolvedEl,ParamResolved,Param);
|
||||
Result:=CheckSrcIsADstType(FromResolved,ToResolved,ErrorEl);
|
||||
if Result=cIncompatible then
|
||||
Result:=CheckSrcIsADstType(ParamResolved,ResolvedEl,Param);
|
||||
Result:=CheckSrcIsADstType(ToResolved,FromResolved,ErrorEl);
|
||||
if Result=cIncompatible then
|
||||
Result:=CheckTypeCastClassInstanceToClass(Param,ParamResolved,ResolvedEl);
|
||||
Result:=CheckTypeCastClassInstanceToClass(FromResolved,ToResolved,ErrorEl);
|
||||
end;
|
||||
end
|
||||
else if ResTypeEl.ClassType=TPasClassOfType then
|
||||
else if C=TPasClassOfType then
|
||||
begin
|
||||
// writeln('TPasResolver.CheckTypeCast class-of ParamResolved.TypeEl=',GetObjName(ParamResolved.TypeEl),' ParamResolved.IdentEl=',GetObjName(ParamResolved.IdentEl));
|
||||
if (ParamResolved.BaseType=btContext) then
|
||||
//writeln('TPasResolver.CheckTypeCast class-of FromRes.TypeEl=',GetObjName(FromResolved.TypeEl),' FromRes.IdentEl=',GetObjName(FromResolved.IdentEl));
|
||||
if (FromResolved.BaseType=btContext) then
|
||||
begin
|
||||
if (ParamResolved.TypeEl.ClassType=TPasClassOfType)
|
||||
and (not (ParamResolved.IdentEl is TPasType)) then
|
||||
if (FromResolved.TypeEl.ClassType=TPasClassOfType)
|
||||
and (not (FromResolved.IdentEl is TPasType)) then
|
||||
begin
|
||||
// type cast classof(classof-var) upwards or downwards
|
||||
ElClassType:=TPasClassOfType(ResTypeEl).DestType;
|
||||
ParamClassType:=TPasClassOfType(ParamResolved.TypeEl).DestType;
|
||||
Result:=CheckClassIsClass(ElClassType,ParamClassType,Param);
|
||||
ToClassType:=TPasClassOfType(ToTypeEl).DestType;
|
||||
FromClassType:=TPasClassOfType(FromResolved.TypeEl).DestType;
|
||||
Result:=CheckClassIsClass(ToClassType,FromClassType,ErrorEl);
|
||||
if Result=cIncompatible then
|
||||
Result:=CheckClassIsClass(ParamClassType,ElClassType,Param);
|
||||
Result:=CheckClassIsClass(FromClassType,ToClassType,ErrorEl);
|
||||
end
|
||||
else if (ParamResolved.TypeEl.ClassType=TPasClassType)
|
||||
and (ParamResolved.IdentEl=ParamResolved.TypeEl) then
|
||||
else if (FromResolved.TypeEl.ClassType=TPasClassType)
|
||||
and (FromResolved.IdentEl=FromResolved.TypeEl) then
|
||||
begin
|
||||
// type case classof(Self) upwards or downwards
|
||||
ElClassType:=TPasClassOfType(ResTypeEl).DestType;
|
||||
ParamClassType:=TPasClassType(ParamResolved.TypeEl);
|
||||
Result:=CheckClassIsClass(ElClassType,ParamClassType,Param);
|
||||
// type cast classof(Self) or classof(aclass) upwards or downwards
|
||||
ToClassType:=TPasClassOfType(ToTypeEl).DestType;
|
||||
FromClassType:=TPasClassType(FromResolved.TypeEl);
|
||||
Result:=CheckClassIsClass(ToClassType,FromClassType,ErrorEl);
|
||||
if Result=cIncompatible then
|
||||
Result:=CheckClassIsClass(ParamClassType,ElClassType,Param);
|
||||
Result:=CheckClassIsClass(FromClassType,ToClassType,ErrorEl);
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else if ResTypeEl.ClassType=TPasEnumType then
|
||||
else if C=TPasEnumType then
|
||||
begin
|
||||
if CheckIsOrdinal(ParamResolved,Param,true) then
|
||||
if CheckIsOrdinal(FromResolved,ErrorEl,true) then
|
||||
Result:=cExact;
|
||||
end
|
||||
else if C=TPasArrayType then
|
||||
begin
|
||||
if (FromResolved.BaseType=btContext)
|
||||
and (FromResolved.TypeEl.ClassType=TPasArrayType) then
|
||||
Result:=CheckTypeCastArray(TPasArrayType(FromResolved.TypeEl),
|
||||
TPasArrayType(ToTypeEl),ErrorEl,RaiseOnError);
|
||||
end;
|
||||
end;
|
||||
|
||||
if Result=cIncompatible then
|
||||
begin
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.CheckTypeCast El=',GetResolverResultDesc(ResolvedEl),' Param=',GetResolverResultDesc(ParamResolved));
|
||||
writeln('TPasResolver.CheckTypeCastRes From=',GetResolverResultDesc(FromResolved),' To=',GetResolverResultDesc(ToResolved));
|
||||
{$ENDIF}
|
||||
if RaiseOnError then
|
||||
RaiseIncompatibleType(20170216152528,nIllegalTypeConversionTo,
|
||||
[],ParamResolved.TypeEl,El,Param);
|
||||
RaiseIncompatibleTypeRes(20170216152528,nIllegalTypeConversionTo,
|
||||
[],FromResolved,ToResolved,ErrorEl);
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
if length(Params.Params)>1 then
|
||||
begin
|
||||
if RaiseOnError then
|
||||
RaiseMsg(20170216152530,nWrongNumberOfParametersForTypeCast,
|
||||
sWrongNumberOfParametersForTypeCast,[El.Name],Params);
|
||||
exit(cIncompatible);
|
||||
end;
|
||||
function TPasResolver.CheckTypeCastArray(FromType, ToType: TPasArrayType;
|
||||
ErrorEl: TPasElement; RaiseOnError: boolean): integer;
|
||||
|
||||
function NextDim(var ArrType: TPasArrayType; var NextIndex: integer;
|
||||
out ElTypeResolved: TPasResolverResult): boolean;
|
||||
begin
|
||||
inc(NextIndex);
|
||||
if NextIndex<length(ArrType.Ranges) then
|
||||
begin
|
||||
ElTypeResolved.BaseType:=btNone;
|
||||
exit(true);
|
||||
end;
|
||||
ComputeElement(ArrType.ElType,ElTypeResolved,[rcType]);
|
||||
if (ElTypeResolved.BaseType<>btContext)
|
||||
or (ElTypeResolved.TypeEl.ClassType<>TPasArrayType) then
|
||||
exit(false);
|
||||
ArrType:=TPasArrayType(ElTypeResolved.TypeEl);
|
||||
NextIndex:=0;
|
||||
Result:=true;
|
||||
end;
|
||||
|
||||
var
|
||||
FromIndex, ToIndex: Integer;
|
||||
FromElTypeRes, ToElTypeRes: TPasResolverResult;
|
||||
StartFromType, StartToType: TPasArrayType;
|
||||
begin
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.CheckTypeCastArray From=',GetTypeDesc(FromType),' ToType=',GetTypeDesc(ToType));
|
||||
{$ENDIF}
|
||||
StartFromType:=FromType;
|
||||
StartToType:=ToType;
|
||||
Result:=cIncompatible;
|
||||
// check dimensions
|
||||
FromIndex:=0;
|
||||
ToIndex:=0;
|
||||
repeat
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.CheckTypeCastArray From=',GetTypeDesc(FromType),' FromIndex=',FromIndex,' ToType=',GetTypeDesc(ToType),' ToIndex=',ToIndex);
|
||||
{$ENDIF}
|
||||
if length(ToType.Ranges)=0 then
|
||||
// ToType is dynamic -> fits any size
|
||||
else
|
||||
begin
|
||||
// ToType is ranged
|
||||
// ToDo: check size of dimension
|
||||
end;
|
||||
// check next dimension
|
||||
if not NextDim(FromType,FromIndex,FromElTypeRes) then
|
||||
begin
|
||||
// at end of FromType
|
||||
if NextDim(ToType,ToIndex,ToElTypeRes) then
|
||||
begin
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.CheckTypeCastArray To has more dims than From: From=',GetTypeDesc(FromType),' FromIndex=',FromIndex,', ToType=',GetTypeDesc(ToType),' ToIndex=',ToIndex);
|
||||
{$ENDIF}
|
||||
break; // ToType has more dimensions
|
||||
end;
|
||||
// have same dimension -> check ElType
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.CheckTypeCastArray check ElType From=',GetResolverResultDesc(FromElTypeRes),' To=',GetResolverResultDesc(ToElTypeRes));
|
||||
{$ENDIF}
|
||||
Include(FromElTypeRes.Flags,rrfReadable);
|
||||
Result:=CheckTypeCastRes(FromElTypeRes,ToElTypeRes,ErrorEl,false);
|
||||
break;
|
||||
end
|
||||
else
|
||||
begin
|
||||
// FromType has more dimensions
|
||||
if not NextDim(ToType,ToIndex,ToElTypeRes) then
|
||||
begin
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.CheckTypeCastArray From has more dims than To: From=',GetTypeDesc(FromType),' FromIndex=',FromIndex,', ToType=',GetTypeDesc(ToType),' ToIndex=',ToIndex);
|
||||
{$ENDIF}
|
||||
break; // ToType has less dimensions
|
||||
end;
|
||||
end;
|
||||
until false;
|
||||
if (Result=cIncompatible) and RaiseOnError then
|
||||
RaiseIncompatibleType(20170331124643,nIllegalTypeConversionTo,
|
||||
[],StartFromType,StartToType,ErrorEl);
|
||||
end;
|
||||
|
||||
procedure TPasResolver.ComputeElement(El: TPasElement; out
|
||||
|
||||
@ -472,6 +472,8 @@ type
|
||||
Procedure TestArray_CopyMismatchFail;
|
||||
Procedure TestArray_InsertDelete;
|
||||
Procedure TestArray_InsertItemMismatchFail;
|
||||
Procedure TestArray_TypeCast;
|
||||
Procedure TestArray_TypeCastWrongElTypeFail;
|
||||
|
||||
// procedure types
|
||||
Procedure TestProcTypesAssignObjFPC;
|
||||
@ -7333,6 +7335,41 @@ begin
|
||||
nIncompatibleTypesGotExpected);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestArray_TypeCast;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('type');
|
||||
Add(' integer = longint;');
|
||||
Add(' TArrIntA = array of integer;');
|
||||
Add(' TArrIntB = array of longint;');
|
||||
Add(' TArrIntC = array of integer;');
|
||||
Add('var');
|
||||
Add(' a: TArrIntA;');
|
||||
Add(' b: TArrIntB;');
|
||||
Add(' c: TArrIntC;');
|
||||
Add('begin');
|
||||
Add(' a:=TArrIntA(a);');
|
||||
Add(' a:=TArrIntA(b);');
|
||||
Add(' a:=TArrIntA(c);');
|
||||
ParseProgram;
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestArray_TypeCastWrongElTypeFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('type');
|
||||
Add(' integer = longint;');
|
||||
Add(' TArrInt = array of integer;');
|
||||
Add(' TArrStr = array of string;');
|
||||
Add('var');
|
||||
Add(' a: TArrInt;');
|
||||
Add(' s: TArrStr;');
|
||||
Add('begin');
|
||||
Add(' a:=TArrInt(s);');
|
||||
CheckResolverException('Illegal type conversion: "TArrStr" to "TArrInt"',
|
||||
nIllegalTypeConversionTo);
|
||||
end;
|
||||
|
||||
procedure TTestResolver.TestProcTypesAssignObjFPC;
|
||||
begin
|
||||
StartProgram(false);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user