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

fcl-passrc: parser: create property stored accessor elements for true and false, resolver: property stored modifier

Browse Source 
git-svn-id: trunk@37309 -
This commit is contained in:
Mattias Gaertner 2017-09-24 07:48:36 +00:00
parent d4deaa39ca
commit 8e450dfd5c
4 changed files with 205 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -884,6 +884,8 @@ type
proClassOfIs, // class-of supports is and as operator
proExtClassInstanceNoTypeMembers, // class members of external class cannot be accessed by instance
proOpenAsDynArrays, // open arrays work like dynamic arrays
//ToDo: proStaticArrayCopy, // copy works with static arrays, returning a dynamic array
//ToDo: proStaticArrayConcat, // concat works with static arrays, returning a dynamic array
proProcTypeWithoutIsNested, // proc types can use nested procs without 'is nested'
proMethodAddrAsPointer // can assign @method to a pointer
);
@ -1351,7 +1353,7 @@ type
function GetPasPropertyAncestor(El: TPasProperty; WithRedeclarations: boolean = false): TPasProperty;
function GetPasPropertyGetter(El: TPasProperty): TPasElement;
function GetPasPropertySetter(El: TPasProperty): TPasElement;
function GetPasPropertyStored(El: TPasProperty): TPasElement;
function GetPasPropertyStoredExpr(El: TPasProperty): TPasExpr;
function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType;
function GetLoop(El: TPasElement): TPasImplElement;
function ResolveAliasType(aType: TPasType): TPasType;
@ -4061,8 +4063,82 @@ var
end;
end;
procedure CheckStoredAccessor(Expr: TPasExpr);
var
ResolvedEl: TPasResolverResult;
Value: TResEvalValue;
Proc: TPasProcedure;
ResultType, TypeEl: TPasType;
aVar: TPasVariable;
IdentEl: TPasElement;
begin
ResolveExpr(Expr,rraRead);
ComputeElement(Expr,ResolvedEl,[rcNoImplicitProc]);
IdentEl:=ResolvedEl.IdentEl;
if IdentEl is TPasProcedure then
begin
// function
Proc:=TPasProcedure(IdentEl);
// check if member
if not (Expr is TPrimitiveExpr) then
RaiseXExpectedButYFound(20170923202002,'member function','foreign '+Proc.ElementTypeName,Expr);
if Proc.ClassType<>TPasFunction then
RaiseXExpectedButYFound(20170216151925,'function',Proc.ElementTypeName,Expr);
// check function result type
ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType;
if not IsBaseType(ResultType,btBoolean,true) then
RaiseXExpectedButYFound(20170923200836,'function: boolean',
'function:'+GetTypeDescription(ResultType),PropEl.StoredAccessor);
// check arg count
if Proc.ProcType.Args.Count<>0 then
RaiseMsg(20170923200840,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo,
[Proc.Name],Expr);
exit;
end;
if (IdentEl<>nil)
and ((IdentEl.ClassType=TPasVariable)
or ((IdentEl.ClassType=TPasConst) and not TPasConst(IdentEl).IsConst))
then
begin
// field
aVar:=TPasVariable(IdentEl);
// check if member
if not (Expr is TPrimitiveExpr) then
RaiseXExpectedButYFound(20170923202003,'member variable','foreign '+aVar.ElementTypeName,Expr);
if PropEl.IndexExpr<>nil then
RaiseNotYetImplemented(20170409214006,PropEl.StoredAccessor,'stored with index');
// check type boolean
TypeEl:=aVar.VarType;
TypeEl:=ResolveAliasType(TypeEl);
if not IsBaseType(TypeEl,btBoolean,true) then
RaiseIncompatibleType(20170409214300,nIncompatibleTypesGotExpected,
[],TypeEl,BaseTypes[btBoolean],Expr);
// check class var
if (vmClass in PropEl.VarModifiers)<>(vmClass in aVar.VarModifiers) then
if vmClass in PropEl.VarModifiers then
RaiseXExpectedButYFound(20170409214351,'class var','var',Expr)
else
RaiseXExpectedButYFound(20170409214359,'var','class var',Expr);
exit;
end;
if (ResolvedEl.BaseType=btBoolean) and (ResolvedEl.ExprEl<>nil) then
begin
// try evaluating const boolean
Value:=Eval(Expr,[refConst]);
if Value<>nil then
try
if Value.Kind<>revkBool then
RaiseXExpectedButYFound(20170923200256,'boolean',GetResolverResultDescription(ResolvedEl),Expr);
exit;
finally
ReleaseEvalValue(Value);
end;
end;
RaiseXExpectedButYFound(20170923194234,'identifier',GetResolverResultDescription(ResolvedEl),Expr);
end;
var
ResultType, TypeEl: TPasType;
ResultType: TPasType;
CurClassType: TPasClassType;
AccEl: TPasElement;
Proc: TPasProcedure;
@ -4204,41 +4280,7 @@ begin
if PropEl.StoredAccessor<>nil then
begin
// check compatibility
AccEl:=GetAccessor(PropEl.StoredAccessor);
if (AccEl.ClassType=TPasVariable) or (AccEl.ClassType=TPasConst) then
begin
if PropEl.IndexExpr<>nil then
RaiseNotYetImplemented(20170409214006,PropEl.StoredAccessor,'stored with index');
TypeEl:=TPasVariable(AccEl).VarType;
// ToDo: TypeEl=nil TPasConst false/true
TypeEl:=ResolveAliasType(TypeEl);
if not IsBaseType(TypeEl,btBoolean,true) 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
// check function
Proc:=TPasProcedure(AccEl);
if Proc.ClassType<>TPasFunction then
RaiseXExpectedButYFound(20170216151925,'function',Proc.ElementTypeName,PropEl.StoredAccessor);
// check function result type
ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType;
if not IsBaseType(ResultType,btBoolean,true) then
RaiseXExpectedButYFound(20170216151929,'function: boolean',
'function:'+GetTypeDescription(ResultType),PropEl.StoredAccessor);
// check arg count
if Proc.ProcType.Args.Count<>0 then
RaiseMsg(20170216151932,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo,
[Proc.Name],PropEl.StoredAccessor);
end
else
RaiseXExpectedButYFound(20170216151935,'function: boolean',AccEl.ElementTypeName,PropEl.StoredAccessor);
CheckStoredAccessor(PropEl.StoredAccessor);
end;
if PropEl.DefaultExpr<>nil then
begin
@ -8860,9 +8902,11 @@ begin
Param:=Params.Params[0];
ComputeElement(Param,ParamResolved,[]);
if (rrfReadable in ParamResolved.Flags)
and (ParamResolved.BaseType=btContext)
and IsDynArray(ParamResolved.TypeEl) then
Result:=cExact;
and (ParamResolved.BaseType=btContext) then
begin
if IsDynArray(ParamResolved.TypeEl) then
Result:=cExact;
end;
if Result=cIncompatible then
exit(CheckRaiseTypeArgNo(20170329153951,1,Param,ParamResolved,'dynamic array',RaiseOnError));
if length(Params.Params)=1 then
@ -11755,18 +11799,15 @@ begin
end;
end;
function TPasResolver.GetPasPropertyStored(El: TPasProperty): TPasElement;
// search the member variable or setter procedure of a property
var
DeclEl: TPasElement;
function TPasResolver.GetPasPropertyStoredExpr(El: TPasProperty): TPasExpr;
// search the stored expression of a property
begin
Result:=nil;
while El<>nil do
begin
if El.StoredAccessor<>nil then
begin
DeclEl:=(El.StoredAccessor.CustomData as TResolvedReference).Declaration;
Result:=DeclEl;
Result:=El.StoredAccessor;
exit;
end;
El:=GetPasPropertyAncestor(El);

2
packages/fcl-passrc/src/pastree.pp
View File

@ -852,7 +852,7 @@ type
TPasConst = class(TPasVariable)
public
IsConst: boolean; // e.g. $WritableConst off
IsConst: boolean; // true iff untyped const or typed with $WritableConst off
function ElementTypeName: string; override;
end;

13
packages/fcl-passrc/src/pparser.pp
View File

@ -3393,7 +3393,10 @@ begin
Ungettoken; // Range type stops on token after last range token}
end
else
begin
UngetToken;
Result.IsConst:=true;
end;
ExpectToken(tkEqual);
NextToken;
Result.Expr:=DoParseConstValueExpression(Result);
@ -4621,9 +4624,15 @@ begin
begin
NextToken;
if CurToken = tkTrue then
Result.StoredAccessorName := 'True'
begin
Result.StoredAccessorName := 'True';
Result.StoredAccessor := CreateBoolConstExpr(Result,pekBoolConst,true);
end
else if CurToken = tkFalse then
Result.StoredAccessorName := 'False'
begin
Result.StoredAccessorName := 'False';
Result.StoredAccessor := CreateBoolConstExpr(Result,pekBoolConst,false);
end
else if CurToken = tkIdentifier then
begin
UngetToken;

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

@ -182,6 +182,7 @@ type
Procedure TestTypedConstWrongExprFail;
Procedure TestVarWrongExprFail;
Procedure TestArgWrongExprFail;
Procedure TestTypedConstInConstExprFail;
Procedure TestVarExternal;
Procedure TestVarNoSemicolonBeginFail;
Procedure TestConstIntOperators;
@ -502,6 +503,7 @@ type
Procedure TestPropertyStoredAccessorProcNotFunc;
Procedure TestPropertyStoredAccessorFuncWrongResult;
Procedure TestPropertyStoredAccessorFuncWrongArgCount;
Procedure TestPropertyDefaultValue;
Procedure TestPropertyAssign;
Procedure TestPropertyAssignReadOnlyFail;
Procedure TestProperty_PassAsParam;
@ -542,13 +544,17 @@ type
Procedure TestArray_DynArrayConst;
Procedure TestArray_AssignNilToStaticArrayFail1;
Procedure TestArray_SetLengthProperty;
Procedure TestStaticArray_SetlengthFail;
Procedure TestArray_PassArrayElementToVarParam;
Procedure TestArray_OpenArrayOfString;
Procedure TestArray_OpenArrayOfString_IntFail;
Procedure TestArray_OpenArrayOverride;
Procedure TestArray_CopyConcat;
Procedure TestStaticArray_CopyConcat;// ToDo
Procedure TestArray_CopyMismatchFail;
Procedure TestArray_InsertDelete;
Procedure TestStaticArray_InsertFail;
Procedure TestStaticArray_DeleteFail;
Procedure TestArray_InsertItemMismatchFail;
Procedure TestArray_TypeCast;
Procedure TestArray_TypeCastWrongElTypeFail;
@ -2127,6 +2133,16 @@ begin
nIncompatibleTypesGotExpected);
end;
procedure TTestResolver.TestTypedConstInConstExprFail;
begin
StartProgram(false);
Add('const');
Add(' a: longint = 3;');
Add(' b: longint = a;');
Add('begin');
CheckResolverException('Constant expression expected',nConstantExpressionExpected);
end;
procedure TTestResolver.TestVarExternal;
begin
StartProgram(false);
@ -7967,6 +7983,7 @@ end;
procedure TTestResolver.TestPropertyStoredAccessor;
begin
StartProgram(false);
Add('const StoreB = true;');
Add('type');
Add(' TObject = class');
Add(' FBird: longint;');
@ -7974,6 +7991,8 @@ begin
Add(' function IsBirdStored: boolean; virtual; abstract;');
Add(' property Bird: longint read FBird stored VStored;');
Add(' property B: longint read FBird stored IsBirdStored;');
Add(' property Eagle: longint read FBird stored StoreB;');
Add(' property Hawk: longint read FBird stored false;');
Add(' end;');
Add('begin');
ParseProgram;
@ -8034,6 +8053,31 @@ begin
nWrongNumberOfParametersForCallTo);
end;
procedure TTestResolver.TestPropertyDefaultValue;
begin
StartProgram(false);
Add([
'const',
' CB = true or false;',
' CI = 1+2;',
'type',
' TEnum = (red, blue);',
' TObject = class',
' FB: boolean;',
' property B1: boolean read FB default true;',
' property B2: boolean read FB default CB;',
' property B3: boolean read FB default afile.cb;',
' FI: longint;',
' property I1: longint read FI default 2;',
' property I2: longint read FI default CI;',
' FE: TEnum;',
' property E1: TEnum read FE default red;',
' property E2: TEnum read FE default TEnum.blue;',
' end;',
'begin']);
ParseProgram;
end;
procedure TTestResolver.TestPropertyArgs1;
begin
StartProgram(false);
@ -8755,6 +8799,17 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestStaticArray_SetlengthFail;
begin
StartProgram(false);
Add('type');
Add(' TArrInt = array[1..3] of longint;');
Add('var a: TArrInt;');
Add('begin');
Add(' SetLength(a,2);');
CheckResolverException(sIncompatibleTypeArgNo,nIncompatibleTypeArgNo);
end;
procedure TTestResolver.TestArray_PassArrayElementToVarParam;
begin
StartProgram(false);
@ -8838,6 +8893,29 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestStaticArray_CopyConcat;
begin
exit;
//ResolverEngine.Options:=ResolverEngine.Options+[proStaticArrayCopy,proStaticArrayConcat];
StartProgram(false);
Add('type');
Add(' integer = longint;');
Add(' TArrayInt = array of integer;');
Add(' TThreeInts = array[1..3] of integer;');
Add('function Get(A: TThreeInts): TThreeInts; begin end;');
Add('var');
Add(' i: integer;');
Add(' A: TArrayInt;');
Add(' S: TThreeInts;');
Add('begin');
Add(' A:=Copy(S);');
Add(' A:=Copy(S,1);');
Add(' A:=Copy(S,2,3);');
Add(' A:=Copy(Get(S),2,3);');
Add(' A:=Concat(S,Get(S));');
ParseProgram;
end;
procedure TTestResolver.TestArray_CopyMismatchFail;
begin
StartProgram(false);
@ -8871,6 +8949,34 @@ begin
CheckAccessMarkers;
end;
procedure TTestResolver.TestStaticArray_InsertFail;
begin
StartProgram(false);
Add('type');
Add(' integer = longint;');
Add(' TArrayInt = array[1..3] of integer;');
Add('var');
Add(' i: integer;');
Add(' A: TArrayInt;');
Add('begin');
Add(' Insert(1,A,i);');
CheckResolverException(sIncompatibleTypeArgNo,nIncompatibleTypeArgNo);
end;
procedure TTestResolver.TestStaticArray_DeleteFail;
begin
StartProgram(false);
Add('type');
Add(' integer = longint;');
Add(' TArrayInt = array[1..3] of integer;');
Add('var');
Add(' i: integer;');
Add(' A: TArrayInt;');
Add('begin');
Add(' Delete(A,i,1);');
CheckResolverException(sIncompatibleTypeArgNo,nIncompatibleTypeArgNo);
end;
procedure TTestResolver.TestArray_InsertItemMismatchFail;
begin
StartProgram(false);