paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 17:59:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: specialize inlinespecializeexpr

Browse Source 
git-svn-id: trunk@42702 -
This commit is contained in:
Mattias Gaertner 2019-08-15 17:25:12 +00:00
parent 0e79bd2c70
commit 32573139a8
6 changed files with 183 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1584,6 +1584,7 @@ type
procedure ResolveSetParamsExpr(Params: TParamsExpr); virtual;
procedure ResolveArrayValues(El: TArrayValues); virtual;
procedure ResolveRecordValues(El: TRecordValues); virtual;
procedure ResolveInlineSpecializeExpr(El: TInlineSpecializeExpr); virtual;
function ResolveAccessor(Expr: TPasExpr): TPasElement;
procedure SetResolvedRefAccess(Expr: TPasExpr; Ref: TResolvedReference;
Access: TResolvedRefAccess); virtual;
@ -6312,13 +6313,16 @@ var
Params, GenericTemplateList: TFPList;
P: TPasElement;
DestType: TPasType;
i: Integer;
i, ScopeDepth: Integer;
begin
{$IFDEF VerbosePasResolver}
//writeln('TPasResolver.FinishSpecializeType ');
{$ENDIF}
// resolve Params
ScopeDepth:=StashSubExprScopes;
Params:=El.Params;
if Params.Count=0 then
RaiseMsg(20190724114416,nMissingParameterX,sMissingParameterX,['type'],El);
for i:=0 to Params.Count-1 do
begin
P:=TPasElement(Params[i]);
@ -6328,11 +6332,9 @@ begin
else
RaiseMsg(20190728113336,nXExpectedButYFound,sXExpectedButYFound,['type identifier',GetObjName(P)+' parameter '+IntToStr(i+1)],El);
end;
if Params.Count=0 then
RaiseMsg(20190724114416,nMissingParameterX,sMissingParameterX,['type'],El);
RestoreStashedScopes(ScopeDepth);
// check DestType
GenericTemplateList:=nil;
DestType:=El.DestType;
if DestType=nil then
RaiseMsg(20190725184734,nIdentifierNotFound,sIdentifierNotFound,['specialize type'],El)
@ -9428,6 +9430,8 @@ begin
end
else if ElClass=TProcedureExpr then
// resolved by FinishScope(stProcedure)
else if ElClass=TInlineSpecializeExpr then
ResolveInlineSpecializeExpr(TInlineSpecializeExpr(El))
else
RaiseNotYetImplemented(20170222184329,El);
@ -10640,6 +10644,33 @@ begin
LogMsg(20180429121127,mtHint,nMissingFieldsX,sMissingFieldsX,[s],El);
end;
procedure TPasResolver.ResolveInlineSpecializeExpr(El: TInlineSpecializeExpr);
var
aName: String;
SpecType: TPasSpecializeType;
Expr: TPasExpr;
GenType: TPasGenericType;
begin
SpecType:=El.DestType;
if SpecType.DestType<>nil then
RaiseNotYetImplemented(20190815092327,El,GetObjName(SpecType.DestType));
// resolve DestType
Expr:=SpecType.Expr;
if Expr=nil then
RaiseNotYetImplemented(20190815091319,SpecType);
if Expr.Kind<>pekIdent then
RaiseNotYetImplemented(20190815083349,Expr);
aName:=TPrimitiveExpr(Expr).Value;
GenType:=FindGenericType(aName,SpecType.Params.Count,Expr);
if GenType=nil then
RaiseMsg(20190815083433,nIdentifierNotFound,sIdentifierNotFound,[aName],Expr);
SpecType.DestType:=GenType;
GenType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasAliasType.DestType'){$ENDIF};
FinishSpecializeType(SpecType);
end;
function TPasResolver.ResolveAccessor(Expr: TPasExpr): TPasElement;
function SubResolvePrimitive(Prim: TPrimitiveExpr): TPasElement;
@ -15879,11 +15910,19 @@ end;
procedure TPasResolver.SpecializeInlineSpecializeExpr(GenEl,
SpecEl: TInlineSpecializeExpr);
var
GenSpec, SpecSpec: TPasSpecializeType;
begin
SpecializeExpr(GenEl,SpecEl);
SpecializeElExpr(GenEl,SpecEl,GenEl.NameExpr,SpecEl.NameExpr);
SpecializeElList(GenEl,SpecEl,GenEl.Params,SpecEl.Params,true
{$IFDEF CheckPasTreeRefCount},'TInlineSpecializeExpr.Params'{$ENDIF});
GenSpec:=GenEl.DestType;
SpecSpec:=TPasSpecializeType.Create('',SpecEl);
SpecEl.DestType:=SpecSpec;
SpecializeElExpr(GenSpec,SpecSpec,GenSpec.Expr,SpecSpec.Expr);
SpecializeElList(GenSpec,SpecSpec,GenSpec.Params,SpecSpec.Params,true
{$IFDEF CheckPasTreeRefCount},'TPasSpecializeType.Params'{$ENDIF});
// SpecSpec.DestType is done in ResolveInlineSpecializeExpr
end;
procedure TPasResolver.SpecializeProcedureExpr(GenEl, SpecEl: TProcedureExpr);
@ -24227,6 +24266,22 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
Include(ResolvedEl.Flags,rrfCanBeStatement);
end;
procedure ComputeSpecializeType(SpecType: TPasSpecializeType);
var
TypeEl: TPasType;
begin
if SpecType.CustomData is TPasSpecializeTypeData then
begin
TypeEl:=TPasSpecializeTypeData(SpecType.CustomData).SpecializedType;
SetResolverIdentifier(ResolvedEl,btContext,TypeEl,TypeEl,TypeEl,[]);
end
else
begin
TypeEl:=SpecType.DestType;
SetResolverIdentifier(ResolvedEl,btContext,SpecType,TypeEl,SpecType,[]);
end;
end;
var
DeclEl: TPasElement;
ElClass: TClass;
@ -24608,18 +24663,9 @@ begin
SetResolverIdentifier(ResolvedEl,btContext,El,TPasGenericTemplateType(El),
TPasGenericTemplateType(El),[])
else if ElClass=TPasSpecializeType then
begin
if El.CustomData is TPasSpecializeTypeData then
begin
TypeEl:=TPasSpecializeTypeData(El.CustomData).SpecializedType;
SetResolverIdentifier(ResolvedEl,btContext,TypeEl,TypeEl,TypeEl,[]);
end
else
begin
TypeEl:=TPasSpecializeType(El).DestType;
SetResolverIdentifier(ResolvedEl,btContext,El,TypeEl,TPasType(El),[]);
end;
end
ComputeSpecializeType(TPasSpecializeType(El))
else if ElClass=TInlineSpecializeExpr then
ComputeSpecializeType(TInlineSpecializeExpr(El).DestType)
else
RaiseNotYetImplemented(20160922163705,El);
{$IF defined(nodejs) and defined(VerbosePasResolver)}

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

@ -604,10 +604,8 @@ type
function GetDeclaration(full : Boolean): string; override;
procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
const Arg: Pointer); override;
procedure AddParam(El: TPasElement);
public
NameExpr: TPasExpr; // TPrimitiveExpr
Params: TFPList; // list of TPasType or TPasExpr
DestType: TPasSpecializeType;
end;
{ TPasClassOfType }
@ -2034,17 +2032,11 @@ constructor TInlineSpecializeExpr.Create(const AName: string;
begin
if AName='' then ;
inherited Create(AParent, pekSpecialize, eopNone);
Params:=TFPList.Create;
end;
destructor TInlineSpecializeExpr.Destroy;
var
i: Integer;
begin
ReleaseAndNil(TPasElement(NameExpr){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF});
for i:=0 to Params.Count-1 do
TPasElement(Params[i]).Release{$IFDEF CheckPasTreeRefCount}('TInlineSpecializeExpr.Params'){$ENDIF};
FreeAndNil(Params);
ReleaseAndNil(TPasElement(DestType){$IFDEF CheckPasTreeRefCount},'CreateElement'{$ENDIF});
inherited Destroy;
end;
@ -2054,34 +2046,15 @@ begin
end;
function TInlineSpecializeExpr.GetDeclaration(full: Boolean): string;
var
i: Integer;
begin
Result:='specialize ';
Result:=Result+NameExpr.GetDeclaration(full);
Result:=Result+'<';
for i:=0 to Params.Count-1 do
begin
if i>0 then
Result:=Result+',';
Result:=Result+TPasElement(Params[i]).GetDeclaration(false);
end;
Result:=DestType.GetDeclaration(full);
end;
procedure TInlineSpecializeExpr.ForEachCall(
const aMethodCall: TOnForEachPasElement; const Arg: Pointer);
var
i: Integer;
begin
inherited ForEachCall(aMethodCall, Arg);
ForEachChildCall(aMethodCall,Arg,NameExpr,false);
for i:=0 to Params.Count-1 do
ForEachChildCall(aMethodCall,Arg,TPasElement(Params[i]),true);
end;
procedure TInlineSpecializeExpr.AddParam(El: TPasElement);
begin
Params.Add(El);
ForEachChildCall(aMethodCall,Arg,DestType,false);
end;
{ TPasSpecializeType }
@ -2119,7 +2092,7 @@ begin
Result:=Result+',';
Result:=Result+TPasElement(Params[i]).GetDeclaration(false);
end;
If Full then
If Full and (Name<>'') then
begin
Result:=Name+' = '+Result;
ProcessHints(False,Result);

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

@ -321,7 +321,7 @@ type
procedure ParseClassMembers(AType: TPasClassType);
procedure ProcessMethod(AType: TPasClassType; IsClass : Boolean; AVisibility : TPasMemberVisibility);
procedure ReadGenericArguments(List : TFPList;Parent : TPasElement);
procedure ReadSpecializeArguments(Spec: TPasElement);
procedure ReadSpecializeArguments(Spec: TPasSpecializeType);
function ReadDottedIdentifier(Parent: TPasElement; out Expr: TPasExpr; NeedAsString: boolean): String;
function CheckProcedureArgs(Parent: TPasElement;
Args: TFPList; // list of TPasArgument
@ -2304,6 +2304,7 @@ var
SrcPos, ScrPos: TPasSourcePos;
ProcType: TProcType;
ProcExpr: TProcedureExpr;
SpecType: TPasSpecializeType;
begin
Result:=nil;
@ -2389,7 +2390,8 @@ begin
UngetToken;
ParseExcExpectedIdentifier;
end;
Last:=CreatePrimitiveExpr(AParent,pekString, '^'+CurTokenText);
Result:=CreatePrimitiveExpr(AParent,pekString, '^'+CurTokenText);
exit;
end;
tkBraceOpen:
begin
@ -2469,11 +2471,37 @@ begin
break
else
begin
// an inline specialization (e.g. A<B,C>)
// an inline specialization (e.g. A<B,C> or something.A<B>)
// check expression in front is an identifier
Expr:=Result;
while Expr.Kind=pekBinary do
begin
if Expr.OpCode<>eopSubIdent then
ParseExcSyntaxError;
Expr:=TBinaryExpr(Expr).right;
end;
if Expr.Kind<>pekIdent then
ParseExcSyntaxError;
// read specialized type
ISE:=TInlineSpecializeExpr(CreateElement(TInlineSpecializeExpr,'',AParent,SrcPos));
ReadSpecializeArguments(ISE);
ISE.NameExpr:=Result;
Result:=ISE;
SpecType:=TPasSpecializeType(CreateElement(TPasSpecializeType,'',ISE,SrcPos));
ISE.DestType:=SpecType;
ReadSpecializeArguments(SpecType);
// can't resolve SpecType.DestType here
// A<B> or something.A<B>
if Expr.Parent is TBinaryExpr then
begin
if TBinaryExpr(Expr.Parent).right<>Expr then
ParseExcSyntaxError;
TBinaryExpr(Expr.Parent).right:=ISE;
ISE.Parent:=Expr.Parent;
end;
SpecType.Expr:=Expr;
Expr.Parent:=SpecType;
if Expr=Result then
Result:=ISE;
ISE:=nil;
CanSpecialize:=aCannot;
NextToken;
@ -4079,19 +4107,8 @@ begin
end;
{$warn 5043 on}
procedure TPasParser.ReadSpecializeArguments(Spec: TPasElement);
procedure TPasParser.ReadSpecializeArguments(Spec: TPasSpecializeType);
// after parsing CurToken is on tkGreaterThan
procedure AddParam(El: TPasElement);
begin
if Spec is TPasSpecializeType then
TPasSpecializeType(Spec).AddParam(El)
else if Spec is TInlineSpecializeExpr then
TInlineSpecializeExpr(Spec).AddParam(El)
else
ParseExcTokenError('[20190619112611] '+Spec.ClassName);
end;
Var
TypeEl: TPasType;
begin
@ -4100,7 +4117,7 @@ begin
repeat
//writeln('ARG TPasParser.ReadSpecializeArguments ',CurTokenText,' ',CurTokenString);
TypeEl:=ParseType(Spec,CurTokenPos,'');
AddParam(TypeEl);
Spec.AddParam(TypeEl);
NextToken;
if CurToken=tkComma then
continue

60
packages/fcl-passrc/tests/tcresolvegenerics.pas
View File

@ -40,6 +40,7 @@ type
procedure TestGen_Record_SpecializeSelfInsideFail;
procedure TestGen_RecordAnoArray;
// ToDo: unitname.specialize TBird<word>.specialize
procedure TestGen_RecordNestedSpecialize;
// generic class
procedure TestGen_Class;
@ -57,10 +58,11 @@ type
// ToDo: ancestor cycle: TBird<T> = class(TBird<word>) fail
// ToDo: class-of
// ToDo: UnitA.impl uses UnitB.intf uses UnitA.intf, UnitB has specialize of UnitA
procedure TestGen_NestedType;
procedure TestGen_Class_NestedType;
// ToDo: procedure TestGen_NestedDottedType;
procedure TestGen_Class_Enums_NotPropagating;
procedure TestGen_Class_List;
// ToDo: procedure TestGen_Class_SubClassType;
// generic external class
procedure TestGen_ExtClass_Array;
@ -84,6 +86,7 @@ type
// generic statements
procedure TestGen_LocalVar;
procedure TestGen_Statements;
procedure TestGen_InlineSpecializeExpr;
// ToDo: for-in
procedure TestGen_TryExcept;
// ToDo: call
@ -359,6 +362,21 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_RecordNestedSpecialize;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' generic TBird<T> = record v: T; end;',
'var',
' a: specialize TBird<specialize TBird<word>>;',
'begin',
' a.v.v:=3;',
'']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_Class;
begin
StartProgram(false);
@ -589,7 +607,7 @@ begin
CheckResolverException('type "TBird" is not yet completely defined',nTypeXIsNotYetCompletelyDefined);
end;
procedure TTestResolveGenerics.TestGen_NestedType;
procedure TTestResolveGenerics.TestGen_Class_NestedType;
begin
StartProgram(false);
Add([
@ -849,6 +867,44 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_InlineSpecializeExpr;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' generic TBird<T> = class',
' constructor Create;',
' end;',
' generic TAnt<U> = class',
' constructor Create;',
' end;',
'constructor TBird.Create;',
'var',
' a: TAnt<T>;',
' b: TAnt<word>;',
'begin',
' a:=TAnt<T>.create;',
' b:=TAnt<word>.create;',
'end;',
'constructor TAnt.Create;',
'var',
' i: TBird<U>;',
' j: TBird<word>;',
' k: TAnt<U>;',
'begin',
' i:=TBird<U>.create;',
' j:=TBird<word>.create;',
' k:=TAnt<U>.create;',
'end;',
'var a: TAnt<word>;',
'begin',
' a:=TAnt<word>.create;',
'']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_TryExcept;
begin
StartProgram(false);

24
packages/pastojs/src/pas2jsfiler.pp
View File

@ -844,6 +844,7 @@ type
procedure Set_Variable_VarType(RefEl: TPasElement; Data: TObject);
procedure Set_AliasType_DestType(RefEl: TPasElement; Data: TObject);
procedure Set_PointerType_DestType(RefEl: TPasElement; Data: TObject);
procedure Set_InlineSpecializeExpr_DestType(RefEl: TPasElement; Data: TObject);
procedure Set_ArrayType_ElType(RefEl: TPasElement; Data: TObject);
procedure Set_FileType_ElType(RefEl: TPasElement; Data: TObject);
procedure Set_SetType_EnumType(RefEl: TPasElement; Data: TObject);
@ -3327,8 +3328,7 @@ procedure TPCUWriter.WriteInlineSpecializeExpr(Obj: TJSONObject;
Expr: TInlineSpecializeExpr; aContext: TPCUWriterContext);
begin
WritePasExpr(Obj,Expr,pekSpecialize,eopNone,aContext);
WriteExpr(Obj,Expr,'Name',Expr.NameExpr,aContext);
WriteElementList(Obj,Expr,'Params',Expr.Params,aContext);
WriteElType(Obj,Expr,'Dest',Expr.DestType,aContext);
end;
procedure TPCUWriter.WriteRangeType(Obj: TJSONObject; El: TPasRangeType;
@ -4249,6 +4249,21 @@ begin
RaiseMsg(20180211121757,El,GetObjName(RefEl));
end;
procedure TPCUReader.Set_InlineSpecializeExpr_DestType(RefEl: TPasElement;
Data: TObject);
var
El: TInlineSpecializeExpr absolute Data;
begin
if RefEl is TPasSpecializeType then
begin
El.DestType:=TPasSpecializeType(RefEl);
if RefEl.Parent<>El then
RefEl.AddRef{$IFDEF CheckPasTreeRefCount}('TInlineSpecializeExpr.DestType'){$ENDIF};
end
else
RaiseMsg(20190815192420,El,GetObjName(RefEl));
end;
procedure TPCUReader.Set_ArrayType_ElType(RefEl: TPasElement; Data: TObject);
var
El: TPasArrayType absolute Data;
@ -6708,10 +6723,7 @@ procedure TPCUReader.ReadInlineSpecializeExpr(Obj: TJSONObject;
Expr: TInlineSpecializeExpr; aContext: TPCUReaderContext);
begin
Expr.Kind:=pekSpecialize;
Expr.NameExpr:=ReadExpr(Obj,Expr,'Name',aContext);
ReadElementList(Obj,Expr,'Params',Expr.Params,
{$IFDEF CheckPasTreeRefCount}'TPasSpecializeType.Params'{$ELSE}true{$ENDIF},
aContext);
ReadElType(Obj,'Dest',Expr,@Set_InlineSpecializeExpr_DestType,aContext);
end;
procedure TPCUReader.ReadRangeType(Obj: TJSONObject; El: TPasRangeType;

3
packages/pastojs/tests/tcfiler.pas
View File

@ -1360,8 +1360,7 @@ end;
procedure TCustomTestPrecompile.CheckRestoredInlineSpecializedExpr(
const Path: string; Orig, Rest: TInlineSpecializeExpr);
begin
CheckRestoredElement(Path+'.NameExpr',Orig.NameExpr,Rest.NameExpr);
CheckRestoredElementList(Path+'.Params',Orig.Params,Rest.Params);
CheckRestoredElement(Path+'.DestType',Orig.DestType,Rest.DestType);
end;
procedure TCustomTestPrecompile.CheckRestoredRangeType(const Path: string;