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

fcl-passrc: resolver: new(out ^record), dispose(^record)

Browse Source 
git-svn-id: trunk@38839 -
This commit is contained in:
Mattias Gaertner 2018-04-24 23:38:24 +00:00
parent 3bc75e6627
commit 2f4af745d9
2 changed files with 137 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -447,7 +447,9 @@ type
bfInsertArray,
bfDeleteArray,
bfTypeInfo,
bfAssert
bfAssert,
bfNew,
bfDispose
);
TResolverBuiltInProcs = set of TResolverBuiltInProc;
const
@ -476,7 +478,9 @@ const
'Insert',
'Delete',
'TypeInfo',
'Assert'
'Assert',
'New',
'Dispose'
);
bfAllStandardProcs = [Succ(bfCustom)..high(TResolverBuiltInProc)];
@ -1463,6 +1467,14 @@ type
Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
procedure BI_Assert_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
Params: TParamsExpr); virtual;
function BI_New_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
procedure BI_New_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
Params: TParamsExpr); virtual;
function BI_Dispose_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
procedure BI_Dispose_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
Params: TParamsExpr); virtual;
public
constructor Create;
destructor Destroy; override;
@ -11327,7 +11339,7 @@ begin
Param:=Params.Params[0];
ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.OnGetCallCompatibility_IncDec ParamResolved=',GetResolverResultDbg(ParamResolved));
writeln('TPasResolver.BI_IncDec_OnGetCallCompatibility ParamResolved=',GetResolverResultDbg(ParamResolved));
{$ENDIF}
Result:=cIncompatible;
// Expr must be a variable
@ -12355,6 +12367,98 @@ begin
FinishAssertCall(Proc,Params);
end;
function TPasResolver.BI_New_OnGetCallCompatibility(
Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
var
Params: TParamsExpr;
Param: TPasExpr;
TypeEl, SubTypeEl: TPasType;
ParamResolved: TPasResolverResult;
begin
if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
exit(cIncompatible);
Params:=TParamsExpr(Expr);
// first param: var PRecord
Param:=Params.Params[0];
ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.BI_New_OnGetCallCompatibility ParamResolved=',GetResolverResultDbg(ParamResolved));
{$ENDIF}
Result:=cIncompatible;
// Expr must be a variable
if not ResolvedElCanBeVarParam(ParamResolved) then
begin
if RaiseOnError then
RaiseMsg(20180425005303,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr);
exit;
end;
if ParamResolved.BaseType=btContext then
begin
TypeEl:=ResolveAliasType(ParamResolved.TypeEl);
if TypeEl.ClassType=TPasPointerType then
begin
SubTypeEl:=ResolveAliasType(TPasPointerType(TypeEl).DestType);
if SubTypeEl.ClassType=TPasRecordType then
Result:=cExact;
end;
end;
if Result=cIncompatible then
exit(CheckRaiseTypeArgNo(20180425005421,1,Param,ParamResolved,'pointer of record',RaiseOnError));
Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
end;
procedure TPasResolver.BI_New_OnFinishParamsExpr(
Proc: TResElDataBuiltInProc; Params: TParamsExpr);
begin
if Proc=nil then ;
FinishCallArgAccess(Params.Params[0],rraOutParam);
end;
function TPasResolver.BI_Dispose_OnGetCallCompatibility(
Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
var
Params: TParamsExpr;
Param: TPasExpr;
TypeEl, SubTypeEl: TPasType;
ParamResolved: TPasResolverResult;
begin
if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
exit(cIncompatible);
Params:=TParamsExpr(Expr);
// first param: var PRecord
Param:=Params.Params[0];
ComputeElement(Param,ParamResolved,[rcNoImplicitProc]);
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.BI_Dispose_OnGetCallCompatibility ParamResolved=',GetResolverResultDbg(ParamResolved));
{$ENDIF}
Result:=cIncompatible;
if (rrfReadable in ParamResolved.Flags) then
if ParamResolved.BaseType=btContext then
begin
TypeEl:=ResolveAliasType(ParamResolved.TypeEl);
if TypeEl.ClassType=TPasPointerType then
begin
SubTypeEl:=ResolveAliasType(TPasPointerType(TypeEl).DestType);
if SubTypeEl.ClassType=TPasRecordType then
Result:=cExact;
end;
end;
if Result=cIncompatible then
exit(CheckRaiseTypeArgNo(20180425010620,1,Param,ParamResolved,'pointer of record',RaiseOnError));
Result:=CheckBuiltInMaxParamCount(Proc,Params,1,RaiseOnError);
end;
procedure TPasResolver.BI_Dispose_OnFinishParamsExpr(
Proc: TResElDataBuiltInProc; Params: TParamsExpr);
begin
if Proc=nil then ;
FinishCallArgAccess(Params.Params[0],rraRead);
end;
constructor TPasResolver.Create;
begin
inherited Create;
@ -13420,6 +13524,14 @@ begin
AddBuiltInProc('Assert','procedure Assert(bool[,string])',
@BI_Assert_OnGetCallCompatibility,nil,nil,
@BI_Assert_OnFinishParamsExpr,bfAssert,[bipfCanBeStatement]);
if bfNew in TheBaseProcs then
AddBuiltInProc('New','procedure New(out ^record)',
@BI_New_OnGetCallCompatibility,nil,nil,
@BI_New_OnFinishParamsExpr,bfNew,[bipfCanBeStatement]);
if bfDispose in TheBaseProcs then
AddBuiltInProc('Dispose','procedure Dispose(var ^record)',
@BI_Dispose_OnGetCallCompatibility,nil,nil,
@BI_Dispose_OnFinishParamsExpr,bfDispose,[bipfCanBeStatement]);
end;
function TPasResolver.AddBaseType(const aName: string; Typ: TResolverBaseType

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

@ -429,6 +429,7 @@ type
Procedure TestRecord_WriteNestedConstParamFail;
Procedure TestRecord_WriteNestedConstParamWithFail;
Procedure TestRecord_TypeCast;
Procedure TestRecord_NewDispose;
// class
Procedure TestClass;
@ -6685,6 +6686,27 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestRecord_NewDispose;
begin
StartProgram(false);
Add([
'type',
' TBird = record',
' Length: longint;',
' end;',
' PBird = ^TBird;',
'var',
' p: PBird;',
' q: ^TBird;',
'begin',
' New(p);',
' Dispose(p);',
' New(q);',
' Dispose(q);',
' ']);
ParseProgram;
end;
procedure TTestResolver.TestClass;
begin
StartProgram(false);