From ba7d698b1d1cff7530fa11f8f20ea984d465352f Mon Sep 17 00:00:00 2001 From: michael Date: Fri, 31 Mar 2017 06:52:48 +0000 Subject: [PATCH] * Patch from Mattias Gaertner: - intrinsics: function concat(array1,array2,...): array function copy(array): array, copy(a,start), copy(a,start,end) insert(item; var array; index: integer) delete(var array; start, count: integer) - unified type mismatch errors and report types with paths if needed git-svn-id: trunk@35692 - --- packages/fcl-passrc/src/pasresolver.pp | 597 +++++++++++++---------- packages/fcl-passrc/tests/tcresolver.pas | 87 +++- 2 files changed, 434 insertions(+), 250 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 34e6fdd7d6..ff3c7555cc 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -103,12 +103,16 @@ Works: - arrays TPasArrayType - TPasEnumType, char, integer, range - low, high, length, setlength, assigned + - function concat(array1,array2,...): array + - function copy(array): array, copy(a,start), copy(a,start,end) + - insert(item; var array; index: integer) + - delete(var array; start, count: integer) - element - multi dimensional - const - open array, override, pass array literal, pass var - check if var initexpr fits vartype: var a: type = expr; -- built-in functions high, low for range types, enums and arrays +- built-in functions high, low for range types - procedure type - method type - function without params: mark if call or address, rrfImplicitCallWithoutParams @@ -446,7 +450,11 @@ type bfPred, bfSucc, bfStrProc, - bfStrFunc + bfStrFunc, + bfConcatArray, + bfCopyArray, + bfInsertArray, + bfDeleteArray ); TResolverBuiltInProcs = set of TResolverBuiltInProc; const @@ -469,7 +477,11 @@ const 'Pred', 'Succ', 'Str', - 'Str' + 'Str', + 'Concat', + 'Copy', + 'Insert', + 'Delete' ); bfAllStandardProcs = [Succ(bfCustom)..high(TResolverBuiltInProc)]; @@ -1080,12 +1092,19 @@ type function IsCharLiteral(const Value: string): boolean; virtual; function CheckBuiltInMinParamCount(Proc: TResElDataBuiltInProc; Expr: TPasExpr; MinCount: integer; RaiseOnError: boolean): boolean; + function CheckBuiltInMaxParamCount(Proc: TResElDataBuiltInProc; Params: TParamsExpr; + MaxCount: integer; RaiseOnError: boolean): integer; + 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( const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean): integer; virtual; + function CheckEqualCompatibilityCustomType( + const LHS, RHS: TPasResolverResult; ErrorEl: TPasElement; + RaiseOnIncompatible: boolean): integer; virtual; protected // built-in functions function BI_Length_OnGetCallCompatibility(Proc: TResElDataBuiltInProc; @@ -1141,6 +1160,22 @@ type Expr: TPasExpr; RaiseOnError: boolean): integer; virtual; procedure BI_StrFunc_OnGetCallResult({%H-}Proc: TResElDataBuiltInProc; {%H-}Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual; + function BI_ConcatArray_OnGetCallCompatibility(Proc: TResElDataBuiltInProc; + Expr: TPasExpr; RaiseOnError: boolean): integer; virtual; + procedure BI_ConcatArray_OnGetCallResult({%H-}Proc: TResElDataBuiltInProc; + {%H-}Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual; + function BI_CopyArray_OnGetCallCompatibility(Proc: TResElDataBuiltInProc; + Expr: TPasExpr; RaiseOnError: boolean): integer; virtual; + procedure BI_CopyArray_OnGetCallResult({%H-}Proc: TResElDataBuiltInProc; + {%H-}Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual; + function BI_InsertArray_OnGetCallCompatibility(Proc: TResElDataBuiltInProc; + Expr: TPasExpr; RaiseOnError: boolean): integer; virtual; + procedure BI_InsertArray_OnFinishParamsExpr(Proc: TResElDataBuiltInProc; + Params: TParamsExpr); virtual; + function BI_DeleteArray_OnGetCallCompatibility(Proc: TResElDataBuiltInProc; + Expr: TPasExpr; RaiseOnError: boolean): integer; virtual; + procedure BI_DeleteArray_OnFinishParamsExpr(Proc: TResElDataBuiltInProc; + Params: TParamsExpr); virtual; public constructor Create; destructor Destroy; override; @@ -1243,7 +1278,7 @@ type function CheckConstArrayCompatibility(Params: TParamsExpr; const ArrayResolved: TPasResolverResult; RaiseOnError: boolean; Flags: TPasResolverComputeFlags; StartEl: TPasElement = nil): integer; - function CheckEqualCompatibilityCustomType( + function CheckEqualCompatibilityUserType( const TypeA, TypeB: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean): integer; function CheckTypeCast(El: TPasType; Params: TParamsExpr; RaiseOnError: boolean): integer; @@ -1417,22 +1452,8 @@ begin end else if (C=TPasUnresolvedTypeRef) then Result:=GetName - else if C=TPasPointerType then - Result:='^'+GetTypeDesc(TPasPointerType(aType).DestType,AddPath) - else if (C=TPasAliasType) - or (C=TPasTypeAliasType) - or (C=TPasClassOfType) - or (C=TPasClassType) - or (C=TPasRecordType) - or (C=TPasEnumType) - or (C=TPasSetType) then - Result:=GetName - else if C=TPasArrayType then - Result:='array['+TPasArrayType(aType).IndexRange+'] of '+GetTypeDesc(TPasArrayType(aType).ElType,AddPath) - else if aType is TPasProcedureType then - Result:=GetProcDesc(TPasProcedureType(aType),false,AddPath) else - Result:=aType.ElementTypeName+' '+GetName; + Result:=GetName; end; function GetTreeDesc(El: TPasElement; Indent: integer): string; @@ -3616,8 +3637,8 @@ var while ArgNo=Proc.ProcType.Args.Count then - RaiseMsg(20170216151805,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo, - [Proc.Name],ErrorEl); + RaiseMsg(20170216151805,nWrongNumberOfParametersForCallTo, + sWrongNumberOfParametersForCallTo,[Proc.Name],ErrorEl); PropArg:=TPasArgument(PropEl.Args[ArgNo]); ProcArg:=TPasArgument(Proc.ProcType.Args[ArgNo]); inc(ArgNo); @@ -6352,6 +6373,30 @@ begin Result:=true; end; +function TPasResolver.CheckBuiltInMaxParamCount(Proc: TResElDataBuiltInProc; + Params: TParamsExpr; MaxCount: integer; RaiseOnError: boolean): integer; +begin + if length(Params.Params)>MaxCount then + begin + if RaiseOnError then + RaiseMsg(20170329154348,nWrongNumberOfParametersForCallTo, + sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[MaxCount]); + exit(cIncompatible); + end; + + Result:=cExact; +end; + +function TPasResolver.CheckRaiseTypeArgNo(id: int64; ArgNo: integer; + Param: TPasExpr; const ParamResolved: TPasResolverResult; Expected: string; + RaiseOnError: boolean): integer; +begin + if RaiseOnError then + RaiseMsg(id,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, + [IntToStr(ArgNo),GetResolverResultDescription(ParamResolved,true),Expected],Param); + Result:=cIncompatible; +end; + function TPasResolver.CheckTypeCastCustomBaseType( const TypeResolved: TPasResolverResult; Param: TPasExpr; const ParamResolved: TPasResolverResult): integer; @@ -6375,6 +6420,16 @@ begin if RaiseOnIncompatible then ; end; +function TPasResolver.CheckEqualCompatibilityCustomType(const LHS, + RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean + ): integer; +begin + Result:=cIncompatible; + if LHS.BaseType=RHS.BaseType then; + if ErrorEl=nil then; + if RaiseOnIncompatible then ; +end; + function TPasResolver.BI_Length_OnGetCallCompatibility( Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; // check params of built in proc 'length' @@ -6402,21 +6457,10 @@ begin end; end; if Result=cIncompatible then - begin - if RaiseOnError then - RaiseMsg(20170216152250,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['1',GetTypeDesc(ParamResolved.TypeEl),'string or array'], - Param); - exit; - end; + exit(CheckRaiseTypeArgNo(20170329160335,1,Param,ParamResolved, + 'string or array',RaiseOnError)); - if length(Params.Params)>1 then - begin - if RaiseOnError then - RaiseMsg(20170216152251,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[1]); - exit(cIncompatible); - end; + Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError); end; procedure TPasResolver.BI_Length_OnGetCallResult(Proc: TResElDataBuiltInProc; @@ -6458,13 +6502,8 @@ begin end; end; if Result=cIncompatible then - begin - if RaiseOnError then - RaiseMsg(20170216152254,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['1',GetTypeDesc(ParamResolved.TypeEl),'string or dynamic array variable'], - Param); - exit(cIncompatible); - end; + exit(CheckRaiseTypeArgNo(20170216152250,1,Param,ParamResolved, + 'string or dynamic array variable',RaiseOnError)); // second param: new length Param:=Params.Params[1]; @@ -6474,20 +6513,10 @@ begin and (ParamResolved.BaseType in btAllInteger) then Result:=cExact; if Result=cIncompatible then - begin - if RaiseOnError then - RaiseMsg(20170216152256,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['2',GetTypeDesc(ParamResolved.TypeEl),'integer'],Param); - exit(cIncompatible); - end; + exit(CheckRaiseTypeArgNo(20170329160338,2,Param,ParamResolved, + 'integer',RaiseOnError)); - if length(Params.Params)>2 then - begin - if RaiseOnError then - RaiseMsg(20170216152257,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[2]); - exit(cIncompatible); - end; + Result:=CheckBuiltInMaxParamCount(Proc,Params,2,RaiseOnError); end; procedure TPasResolver.BI_SetLength_OnFinishParamsExpr( @@ -6531,11 +6560,8 @@ begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.OnGetCallCompatibility_InExclude ',GetResolverResultDesc(ParamResolved)); {$ENDIF} - if RaiseOnError then - RaiseMsg(20170216152301,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['1',GetTypeDesc(ParamResolved.TypeEl),'variable of set of enumtype'], - Param); - exit(cIncompatible); + exit(CheckRaiseTypeArgNo(20170216152301,1,Param,ParamResolved, + 'variable of set of enumtype',RaiseOnError)); end; // second param: enum @@ -6550,15 +6576,7 @@ begin exit(cIncompatible); end; - if length(Params.Params)>2 then - begin - if RaiseOnError then - RaiseMsg(20170216152304,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[2]); - exit(cIncompatible); - end; - - Result:=cExact; + Result:=CheckBuiltInMaxParamCount(Proc,Params,2,RaiseOnError); end; procedure TPasResolver.BI_InExclude_OnFinishParamsExpr( @@ -6585,10 +6603,7 @@ begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.OnGetCallCompatibility_Break Params=',length(Params.Params)); {$ENDIF} - if RaiseOnError then - RaiseMsg(20170216152308,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[1]); - Result:=cIncompatible; + Result:=CheckBuiltInMaxParamCount(Proc,Params,0,RaiseOnError); end; function TPasResolver.BI_Continue_OnGetCallCompatibility( @@ -6604,10 +6619,7 @@ begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.OnGetCallCompatibility_Continue Params=',length(Params.Params)); {$ENDIF} - if RaiseOnError then - RaiseMsg(20170216152311,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[1]); - Result:=cIncompatible; + Result:=CheckBuiltInMaxParamCount(Proc,Params,0,RaiseOnError); end; function TPasResolver.BI_Exit_OnGetCallCompatibility(Proc: TResElDataBuiltInProc; @@ -6669,22 +6681,12 @@ begin if Result=cIncompatible then begin if RaiseOnError then - RaiseMsg(20170216152314,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['1',GetResolverResultDescription(ParamResolved,true), - GetResolverResultDescription(ResultResolved,true)], - Param); + RaiseIncompatibleTypeRes(20170216152314,nIncompatibleTypeArgNo, + ['1'],ParamResolved,ResultResolved,Param); exit; end; - if length(Params.Params)>1 then - begin - if RaiseOnError then - RaiseMsg(20170216152316,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[1]); - exit(cIncompatible); - end; - - Result:=cExact; + Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError); end; function TPasResolver.BI_IncDec_OnGetCallCompatibility( @@ -6715,13 +6717,7 @@ begin if ParamResolved.BaseType in btAllInteger then Result:=cExact; if Result=cIncompatible then - begin - if RaiseOnError then - RaiseMsg(20170216152320,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['1',GetTypeDesc(ParamResolved.TypeEl),'integer'], - Param); - exit; - end; + exit(CheckRaiseTypeArgNo(20170216152320,1,Param,ParamResolved,'integer',RaiseOnError)); if length(Params.Params)=1 then exit; @@ -6736,23 +6732,9 @@ begin Result:=cExact; end; if Result=cIncompatible then - begin - if RaiseOnError then - RaiseMsg(20170216152322,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['2',GetTypeDesc(IncrResolved.TypeEl),'integer'], - Param); - exit; - end; + exit(CheckRaiseTypeArgNo(20170216152322,2,Param,IncrResolved,'integer',RaiseOnError)); - if length(Params.Params)>2 then - begin - if RaiseOnError then - RaiseMsg(20170216152324,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[2]); - exit(cIncompatible); - end; - - Result:=cExact; + Result:=CheckBuiltInMaxParamCount(Proc,Params,2,RaiseOnError); end; procedure TPasResolver.BI_IncDec_OnFinishParamsExpr( @@ -6796,23 +6778,9 @@ begin Result:=cExact; end; if Result=cIncompatible then - begin - if RaiseOnError then - RaiseMsg(20170216152329,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['1',GetTypeDesc(ParamResolved.TypeEl),'class or array'], - Param); - exit; - end; + exit(CheckRaiseTypeArgNo(20170216152329,1,Param,ParamResolved,'class or array',RaiseOnError)); - if length(Params.Params)>1 then - begin - if RaiseOnError then - RaiseMsg(20170216152331,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[1]); - exit(cIncompatible); - end; - - Result:=cExact; + Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError); end; procedure TPasResolver.BI_Assigned_OnGetCallResult(Proc: TResElDataBuiltInProc; @@ -6842,23 +6810,9 @@ begin Result:=cExact; end; if Result=cIncompatible then - begin - if RaiseOnError then - RaiseMsg(20170325185321,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['1',GetTypeDesc(ParamResolved.TypeEl),'integer'], - Param); - exit; - end; + exit(CheckRaiseTypeArgNo(20170325185321,1,Param,ParamResolved,'integer',RaiseOnError)); - if length(Params.Params)>1 then - begin - if RaiseOnError then - RaiseMsg(20170325185323,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[1]); - exit(cIncompatible); - end; - - Result:=cExact; + Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError); end; procedure TPasResolver.BI_Chr_OnGetCallResult(Proc: TResElDataBuiltInProc; @@ -6890,23 +6844,9 @@ begin Result:=cExact; end; if Result=cIncompatible then - begin - if RaiseOnError then - RaiseMsg(20170216152334,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['1',GetTypeDesc(ParamResolved.TypeEl),'enum or char'], - Param); - exit; - end; + exit(CheckRaiseTypeArgNo(20170216152334,1,Param,ParamResolved,'enum or char',RaiseOnError)); - if length(Params.Params)>1 then - begin - if RaiseOnError then - RaiseMsg(20170216152335,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[1]); - exit(cIncompatible); - end; - - Result:=cExact; + Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError); end; procedure TPasResolver.BI_Ord_OnGetCallResult(Proc: TResElDataBuiltInProc; @@ -6944,23 +6884,9 @@ begin Result:=cExact; end; if Result=cIncompatible then - begin - if RaiseOnError then - RaiseMsg(20170216152338,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['1',GetTypeDesc(ParamResolved.TypeEl),'enum or char'], - Param); - exit; - end; + exit(CheckRaiseTypeArgNo(20170216152338,1,Param,ParamResolved,'enum or char',RaiseOnError)); - if length(Params.Params)>1 then - begin - if RaiseOnError then - RaiseMsg(20170216152340,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[1]); - exit(cIncompatible); - end; - - Result:=cExact; + Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError); end; procedure TPasResolver.BI_LowHigh_OnGetCallResult(Proc: TResElDataBuiltInProc; @@ -7022,23 +6948,9 @@ begin if CheckIsOrdinal(ParamResolved,Param,false) then Result:=cExact; if Result=cIncompatible then - begin - if RaiseOnError then - RaiseMsg(20170216152343,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['1',GetTypeDesc(ParamResolved.TypeEl),'ordinal'], - Param); - exit; - end; + exit(CheckRaiseTypeArgNo(20170216152343,1,Param,ParamResolved,'ordinal',RaiseOnError)); - if length(Params.Params)>1 then - begin - if RaiseOnError then - RaiseMsg(20170216152345,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[1]); - exit(cIncompatible); - end; - - Result:=cExact; + Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError); end; procedure TPasResolver.BI_PredSucc_OnGetCallResult(Proc: TResElDataBuiltInProc; @@ -7105,13 +7017,7 @@ begin Result:=cExact end; if Result=cIncompatible then - begin - if RaiseOnError then - RaiseMsg(20170319220517,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - [IntToStr(ArgNo),GetTypeDesc(ParamResolved.TypeEl),'boolean, integer, enum value'], - Param); - exit; - end; + exit(CheckRaiseTypeArgNo(20170319220517,ArgNo,Param,ParamResolved,'boolean, integer, enum value',RaiseOnError)); if not CheckFormat(Param.format1,1,ParamResolved) then exit(cIncompatible); if not CheckFormat(Param.format2,2,ParamResolved) then @@ -7154,23 +7060,9 @@ begin Result:=cExact; end; if Result=cIncompatible then - begin - if RaiseOnError then - RaiseMsg(20170319220806,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - ['1',GetTypeDesc(ParamResolved.TypeEl),'string variable'], - Param); - exit; - end; + exit(CheckRaiseTypeArgNo(20170319220806,1,Param,ParamResolved,'string variable',RaiseOnError)); - if length(Params.Params)>2 then - begin - if RaiseOnError then - RaiseMsg(20170216152345,nWrongNumberOfParametersForCallTo, - sWrongNumberOfParametersForCallTo,[Proc.Signature],Params.Params[2]); - exit(cIncompatible); - end; - - Result:=cExact; + Result:=CheckBuiltInMaxParamCount(Proc,Params,2,RaiseOnError); end; procedure TPasResolver.BI_StrProc_OnFinishParamsExpr(Proc: TResElDataBuiltInProc; @@ -7198,13 +7090,11 @@ begin if not ParentNeedsExprResult(Params) then begin // not in an expression -> the 'procedure str' is needed, not the 'function str' - writeln('AAA1 TPasResolver.BI_StrFunc_OnGetCallCompatibility ',GetObjName(Params.Parent)); if RaiseOnError then RaiseMsg(20170326084622,nIncompatibleTypesGotExpected, sIncompatibleTypesGotExpected,['function str','procedure str'],Params); exit(cIncompatible); end; - writeln('AAA2 TPasResolver.BI_StrFunc_OnGetCallCompatibility ',GetObjName(Params.Parent)); // param: string, boolean, integer, enum, class instance for i:=0 to length(Params.Params)-1 do @@ -7226,6 +7116,212 @@ begin SetResolverIdentifier(ResolvedEl,btString,Proc.Proc,FBaseTypes[btString],[rrfReadable]); end; +function TPasResolver.BI_ConcatArray_OnGetCallCompatibility( + Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; +var + Params: TParamsExpr; + Param: TPasExpr; + ParamResolved, ElTypeResolved, FirstElTypeResolved: TPasResolverResult; + i: Integer; +begin + Result:=cIncompatible; + if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then + exit; + Params:=TParamsExpr(Expr); + + FirstElTypeResolved:=Default(TPasResolverResult); + for i:=0 to length(Params.Params)-1 do + begin + // all params: array + Param:=Params.Params[i]; + ComputeElement(Param,ParamResolved,[]); + if not (rrfReadable in ParamResolved.Flags) + or (ParamResolved.BaseType<>btContext) + or not IsDynArray(ParamResolved.TypeEl) then + exit(CheckRaiseTypeArgNo(20170329181206,i+1,Param,ParamResolved,'dynamic array',RaiseOnError)); + ComputeElement(TPasArrayType(ParamResolved.TypeEl).ElType,ElTypeResolved,[rcType]); + Include(ElTypeResolved.Flags,rrfReadable); + if i=0 then + begin + FirstElTypeResolved:=ElTypeResolved; + Include(ElTypeResolved.Flags,rrfWritable); + end + else if CheckAssignResCompatibility(FirstElTypeResolved,ElTypeResolved,Param,RaiseOnError)=cIncompatible then + exit(cIncompatible); + end; +end; + +procedure TPasResolver.BI_ConcatArray_OnGetCallResult( + Proc: TResElDataBuiltInProc; Params: TParamsExpr; out + ResolvedEl: TPasResolverResult); +begin + ComputeElement(Params.Params[0],ResolvedEl,[]); + ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable]; +end; + +function TPasResolver.BI_CopyArray_OnGetCallCompatibility( + Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; +var + Params: TParamsExpr; + Param: TPasExpr; + ParamResolved: TPasResolverResult; +begin + Result:=cIncompatible; + if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then + exit; + Params:=TParamsExpr(Expr); + + // first param: array + Param:=Params.Params[0]; + ComputeElement(Param,ParamResolved,[]); + if (rrfReadable in ParamResolved.Flags) + and (ParamResolved.BaseType=btContext) + and IsDynArray(ParamResolved.TypeEl) then + Result:=cExact; + if Result=cIncompatible then + exit(CheckRaiseTypeArgNo(20170329153951,1,Param,ParamResolved,'dynamic array',RaiseOnError)); + if length(Params.Params)=1 then + exit(cExact); + + // check optional Start index + Param:=Params.Params[1]; + ComputeElement(Param,ParamResolved,[]); + if not (rrfReadable in ParamResolved.Flags) + or not (ParamResolved.BaseType in btAllInteger) then + exit(CheckRaiseTypeArgNo(20170329164210,2,Param,ParamResolved,'integer',RaiseOnError)); + if length(Params.Params)=2 then + exit(cExact); + + // check optional Count + Param:=Params.Params[2]; + ComputeElement(Param,ParamResolved,[]); + if not (rrfReadable in ParamResolved.Flags) + or not (ParamResolved.BaseType in btAllInteger) then + exit(CheckRaiseTypeArgNo(20170329164329,3,Param,ParamResolved,'integer',RaiseOnError)); + + Result:=CheckBuiltInMaxParamCount(Proc,Params,3,RaiseOnError); +end; + +procedure TPasResolver.BI_CopyArray_OnGetCallResult( + Proc: TResElDataBuiltInProc; Params: TParamsExpr; out + ResolvedEl: TPasResolverResult); +begin + ComputeElement(Params.Params[0],ResolvedEl,[]); + ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable]; +end; + +function TPasResolver.BI_InsertArray_OnGetCallCompatibility( + Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; +// Insert(Item,var Array,Index) +var + Params: TParamsExpr; + Param, ItemParam: TPasExpr; + ItemResolved, ParamResolved, ElTypeResolved: TPasResolverResult; +begin + Result:=cIncompatible; + if not CheckBuiltInMinParamCount(Proc,Expr,3,RaiseOnError) then + exit; + Params:=TParamsExpr(Expr); + + // check Item + ItemParam:=Params.Params[0]; + ComputeElement(ItemParam,ItemResolved,[]); + if not (rrfReadable in ItemResolved.Flags) then + exit(CheckRaiseTypeArgNo(20170329171400,1,ItemParam,ItemResolved,'value',RaiseOnError)); + + // check Array + Param:=Params.Params[1]; + ComputeElement(Param,ParamResolved,[]); + if not ResolvedElCanBeVarParam(ParamResolved) then + begin + if RaiseOnError then + RaiseMsg(20170329171514,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Param); + exit; + end; + if (ParamResolved.BaseType<>btContext) + or not IsDynArray(ParamResolved.TypeEl) then + exit(CheckRaiseTypeArgNo(20170329172024,2,Param,ParamResolved,'dynamic array',RaiseOnError)); + ComputeElement(TPasArrayType(ParamResolved.TypeEl).ElType,ElTypeResolved,[rcType]); + if CheckAssignResCompatibility(ElTypeResolved,ItemResolved,ItemParam,RaiseOnError)=cIncompatible then + exit(cIncompatible); + + // check insert Index + Param:=Params.Params[2]; + ComputeElement(Param,ParamResolved,[]); + if not (rrfReadable in ParamResolved.Flags) + or not (ParamResolved.BaseType in btAllInteger) then + exit(CheckRaiseTypeArgNo(20170329172348,3,Param,ParamResolved,'integer',RaiseOnError)); + + Result:=CheckBuiltInMaxParamCount(Proc,Params,3,RaiseOnError); +end; + +procedure TPasResolver.BI_InsertArray_OnFinishParamsExpr( + Proc: TResElDataBuiltInProc; Params: TParamsExpr); +var + P: TPasExprArray; +begin + if Proc=nil then ; + P:=Params.Params; + FinishParamExpressionAccess(P[0],rraRead); + FinishParamExpressionAccess(P[1],rraVarParam); + FinishParamExpressionAccess(P[2],rraRead); +end; + +function TPasResolver.BI_DeleteArray_OnGetCallCompatibility( + Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer; +// Delete(var Array; Start, Count: integer) +var + Params: TParamsExpr; + Param: TPasExpr; + ParamResolved: TPasResolverResult; +begin + Result:=cIncompatible; + if not CheckBuiltInMinParamCount(Proc,Expr,3,RaiseOnError) then + exit; + Params:=TParamsExpr(Expr); + + // check Array + Param:=Params.Params[0]; + ComputeElement(Param,ParamResolved,[]); + if not ResolvedElCanBeVarParam(ParamResolved) then + begin + if RaiseOnError then + RaiseMsg(20170329173421,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Param); + exit; + end; + if (ParamResolved.BaseType<>btContext) + or not IsDynArray(ParamResolved.TypeEl) then + exit(CheckRaiseTypeArgNo(20170329173434,1,Param,ParamResolved,'dynamic array',RaiseOnError)); + + // check param Start + Param:=Params.Params[1]; + ComputeElement(Param,ParamResolved,[]); + if not (rrfReadable in ParamResolved.Flags) + or not (ParamResolved.BaseType in btAllInteger) then + exit(CheckRaiseTypeArgNo(20170329173613,2,Param,ParamResolved,'integer',RaiseOnError)); + + // check param Count + Param:=Params.Params[2]; + ComputeElement(Param,ParamResolved,[]); + if not (rrfReadable in ParamResolved.Flags) + or not (ParamResolved.BaseType in btAllInteger) then + exit(CheckRaiseTypeArgNo(20170329172348,3,Param,ParamResolved,'integer',RaiseOnError)); + + Result:=CheckBuiltInMaxParamCount(Proc,Params,3,RaiseOnError); +end; + +procedure TPasResolver.BI_DeleteArray_OnFinishParamsExpr( + Proc: TResElDataBuiltInProc; Params: TParamsExpr); +var + P: TPasExprArray; +begin + if Proc=nil then ; + P:=Params.Params; + FinishParamExpressionAccess(P[0],rraVarParam); + FinishParamExpressionAccess(P[1],rraRead); + FinishParamExpressionAccess(P[2],rraRead); +end; + constructor TPasResolver.Create; begin inherited Create; @@ -7816,6 +7912,20 @@ begin if bfStrFunc in TheBaseProcs then AddBuiltInProc('Str','function Str(const var): String', @BI_StrFunc_OnGetCallCompatibility,@BI_StrFunc_OnGetCallResult,nil,bfStrFunc); + if bfConcatArray in TheBaseProcs then + AddBuiltInProc('Concat','function Concat(const Array1, Array2, ...): Array', + @BI_ConcatArray_OnGetCallCompatibility,@BI_ConcatArray_OnGetCallResult,nil,bfConcatArray); + if bfCopyArray in TheBaseProcs then + AddBuiltInProc('Copy','function Copy(const Array; Start: integer = 0; Count: integer = all): Array', + @BI_CopyArray_OnGetCallCompatibility,@BI_CopyArray_OnGetCallResult,nil,bfCopyArray); + if bfInsertArray in TheBaseProcs then + AddBuiltInProc('Insert','procedure Insert(const Element; var Array; Index: integer)', + @BI_InsertArray_OnGetCallCompatibility,nil, + @BI_InsertArray_OnFinishParamsExpr,bfInsertArray,[bipfCanBeStatement]); + if bfDeleteArray in TheBaseProcs then + AddBuiltInProc('Delete','procedure Delete(var Array; Start, Count: integer)', + @BI_DeleteArray_OnGetCallCompatibility,nil, + @BI_DeleteArray_OnFinishParamsExpr,bfDeleteArray,[bipfCanBeStatement]); end; function TPasResolver.AddBaseType(const aName: string; Typ: TResolverBaseType @@ -8415,21 +8525,9 @@ begin begin // dynamic array -> needs exactly one integer GetNextParam; - if not (ParamResolved.BaseType in btAllInteger) then - begin - if not RaiseOnError then exit(cIncompatible); - RaiseMsg(20170216152417,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - [IntToStr(ArgNo),BaseTypeNames[ParamResolved.BaseType],'integer'], - Param); - end; - if not (rrfReadable in ParamResolved.Flags) then - begin - if not RaiseOnError then exit(cIncompatible); - RaiseMsg(20170216152419,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - [IntToStr(ArgNo),GetResolverResultDescription(ParamResolved,true), - 'integer'], - Param); - end; + if (not (rrfReadable in ParamResolved.Flags)) + or not (ParamResolved.BaseType in btAllInteger) then + exit(CheckRaiseTypeArgNo(20170216152417,ArgNo,Param,ParamResolved,'integer',RaiseOnError)); end else begin @@ -8444,10 +8542,8 @@ begin if not (rrfReadable in ParamResolved.Flags) then begin if not RaiseOnError then exit(cIncompatible); - RaiseMsg(20170216152421,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - [IntToStr(ArgNo),GetResolverResultDescription(ParamResolved,true), - GetResolverResultDescription(RangeResolved,true)], - Param); + RaiseIncompatibleTypeRes(20170216152421,nIncompatibleTypeArgNo, + [IntToStr(ArgNo)],ParamResolved,RangeResolved,Param); end; if (bt in btAllBooleans) and (ParamResolved.BaseType in btAllBooleans) then continue @@ -8463,10 +8559,8 @@ begin end; // incompatible if not RaiseOnError then exit(cIncompatible); - RaiseMsg(20170216152422,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - [IntToStr(ArgNo),GetResolverResultDescription(ParamResolved,true), - GetResolverResultDescription(RangeResolved,true)], - Param); + RaiseIncompatibleTypeRes(20170216152422,nIncompatibleTypeArgNo, + [IntToStr(ArgNo)],ParamResolved,RangeResolved,Param); end; end; if ArgNo=length(Params.Params) then exit(cExact); @@ -8775,7 +8869,7 @@ begin // create error messages RaiseIncompatibleTypeRes(20170216152437,nIncompatibleTypesGotExpected, - [],LHS,RHS,ErrorEl); + [],RHS,LHS,ErrorEl); end; function TPasResolver.CheckEqualElCompatibility(Left, Right: TPasElement; @@ -8824,10 +8918,18 @@ begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.CheckEqualCompatibility LHS=',GetResolverResultDesc(LHS),' RHS=',GetResolverResultDesc(RHS)); {$ENDIF} - if LHS.BaseType=RHS.BaseType then + if (LHS.BaseType=btCustom) or (RHS.BaseType=btCustom) then + begin + Result:=CheckEqualCompatibilityCustomType(LHS,RHS,ErrorEl,RaiseOnIncompatible); + if (Result=cIncompatible) and RaiseOnIncompatible then + RaiseIncompatibleTypeRes(20170330010727,nIncompatibleTypesGotExpected, + [],RHS,LHS,ErrorEl); + exit; + end + else if LHS.BaseType=RHS.BaseType then begin if LHS.BaseType=btContext then - exit(CheckEqualCompatibilityCustomType(LHS,RHS,ErrorEl,RaiseOnIncompatible)) + exit(CheckEqualCompatibilityUserType(LHS,RHS,ErrorEl,RaiseOnIncompatible)) else exit(cExact); // same base type, maybe not same type name (e.g. longint and integer) end @@ -9095,9 +9197,8 @@ begin Result:=CheckAssignResCompatibility(ParamResolved,ExprResolved,Expr,false); if (Result=cIncompatible) and RaiseOnError then - RaiseMsg(20170216152454,nIncompatibleTypeArgNo,sIncompatibleTypeArgNo, - [IntToStr(ParamNo+1),GetResolverResultDescription(ExprResolved,true), - GetResolverResultDescription(ParamResolved,true)],Expr); + RaiseIncompatibleTypeRes(20170216152454,nIncompatibleTypeArgNo, + [IntToStr(ParamNo+1)],ExprResolved,ParamResolved,Expr); end; function TPasResolver.CheckAssignCompatibilityUserType(const LHS, @@ -9368,7 +9469,7 @@ begin end; end; -function TPasResolver.CheckEqualCompatibilityCustomType(const TypeA, +function TPasResolver.CheckEqualCompatibilityUserType(const TypeA, TypeB: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean ): integer; var diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 8be69ac4a4..b49a3c93f2 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -268,6 +268,7 @@ type Procedure TestProcParam; Procedure TestProcParamAccess; Procedure TestFunctionResult; + Procedure TestProcedureResultFail; Procedure TestProcOverload; Procedure TestProcOverloadWithBaseTypes; Procedure TestProcOverloadWithClassTypes; @@ -467,6 +468,10 @@ type Procedure TestArray_OpenArrayOfString; Procedure TestArray_OpenArrayOfString_IntFail; Procedure TestArray_OpenArrayOverride; + Procedure TestArray_CopyConcat; + Procedure TestArray_CopyMismatchFail; + Procedure TestArray_InsertDelete; + Procedure TestArray_InsertItemMismatchFail; // procedure types Procedure TestProcTypesAssignObjFPC; @@ -3451,6 +3456,15 @@ begin ParseProgram; end; +procedure TTestResolver.TestProcedureResultFail; +begin + StartProgram(false); + Add('procedure A: longint; begin end;'); + Add('begin'); + CheckParserException('Expected ";" at token ":" in file afile.pp at line 2 column 12', + nParserExpectTokenError); +end; + procedure TTestResolver.TestProcOverload; var El: TPasElement; @@ -6005,13 +6019,13 @@ begin Add(' TObject = class'); Add(' class var FA: longint;'); Add(' class function GetA: longint; static;'); - Add(' class procedure SetA(Value: longint): longint; static;'); + Add(' class procedure SetA(Value: longint); static;'); Add(' class property A1: longint read FA write SetA;'); Add(' class property A2: longint read GetA write FA;'); Add(' end;'); Add(' TObjectClass = class of TObject;'); Add('class function TObject.GetA: longint; begin end;'); - Add('class procedure TObject.SetA(Value: longint): longint; begin end;'); + Add('class procedure TObject.SetA(Value: longint); begin end;'); Add('var'); Add(' o: TObject;'); Add(' oc: TObjectClass;'); @@ -7250,6 +7264,75 @@ begin ParseProgram; end; +procedure TTestResolver.TestArray_CopyConcat; +begin + StartProgram(false); + Add('type'); + Add(' integer = longint;'); + Add(' TArrayInt = array of integer;'); + Add('function Get(A: TArrayInt): TArrayInt; begin end;'); + Add('var'); + Add(' i: integer;'); + Add(' A: TArrayInt;'); + Add('begin'); + Add(' A:=Copy(A);'); + Add(' A:=Copy(A,1);'); + Add(' A:=Copy(A,2,3);'); + Add(' A:=Copy(Get(A),2,3);'); + Add(' Get(Copy(A));'); + Add(' A:=Concat(A);'); + Add(' A:=Concat(A,Get(A));'); + ParseProgram; +end; + +procedure TTestResolver.TestArray_CopyMismatchFail; +begin + StartProgram(false); + Add('type'); + Add(' integer = longint;'); + Add(' TArrayInt = array of integer;'); + Add(' TArrayStr = array of string;'); + Add('var'); + Add(' i: integer;'); + Add(' A: TArrayInt;'); + Add(' B: TArrayStr;'); + Add('begin'); + Add(' A:=Copy(B);'); + CheckResolverException('Incompatible types: got "array of integer" expected "array of String"', + nIncompatibleTypesGotExpected); +end; + +procedure TTestResolver.TestArray_InsertDelete; +begin + StartProgram(false); + Add('type'); + Add(' integer = longint;'); + Add(' TArrayInt = array of integer;'); + Add('var'); + Add(' i: integer;'); + Add(' A: TArrayInt;'); + Add('begin'); + Add(' Insert({#a1_read}i+1,{#a2_var}A,{#a3_read}i+2);'); + Add(' Delete({#b1_var}A,{#b2_read}i+3,{#b3_read}i+4);'); + ParseProgram; + CheckAccessMarkers; +end; + +procedure TTestResolver.TestArray_InsertItemMismatchFail; +begin + StartProgram(false); + Add('type'); + Add(' TCaption = string;'); + Add(' TArrayCap = array of TCaption;'); + Add('var'); + Add(' i: longint;'); + Add(' A: TArrayCap;'); + Add('begin'); + Add(' Insert(i,{#a2_var}A,2);'); + CheckResolverException('Incompatible types: got "Longint" expected "String"', + nIncompatibleTypesGotExpected); +end; + procedure TTestResolver.TestProcTypesAssignObjFPC; begin StartProgram(false);