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

fcl-passrc: specialize type reference

Browse Source 
git-svn-id: trunk@42663 -
This commit is contained in:
Mattias Gaertner 2019-08-12 19:47:18 +00:00
parent 5edc520468
commit 59e0d334b5
3 changed files with 137 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5625,7 +5625,7 @@ var
aType: TPasType;
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishTypeDef El=',GetObjName(El));
//writeln('TPasResolver.FinishTypeDef El=',GetObjName(El));
{$ENDIF}
C:=El.ClassType;
if C=TPasEnumType then
@ -6285,6 +6285,9 @@ var
DestType: TPasType;
i: Integer;
begin
{$IFDEF VerbosePasResolver}
//writeln('TPasResolver.FinishSpecializeType ');
{$ENDIF}
// resolve Params
Params:=El.Params;
for i:=0 to Params.Count-1 do
@ -11164,6 +11167,7 @@ var
i: Integer;
Scope: TPasScope;
Old: TPasIdentifier;
ClassOrRec: TPasMembersType;
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.AddEnumValue ',GetObjName(El));
@ -11189,6 +11193,9 @@ begin
Old:=TPasIdentifierScope(Scope).FindIdentifier(El.Name);
if Old=nil then
TPasIdentifierScope(Scope).AddIdentifier(El.Name,El,pikSimple);
ClassOrRec:=Scope.Element as TPasMembersType;
if GetTypeParameterCount(ClassOrRec)>0 then
break; // enums in generics do not propagate
end
else if (Scope is TPasProcedureScope) or (Scope is TPasSectionScope) then
begin
@ -14435,6 +14442,9 @@ begin
if ParamType is TPasGenericTemplateType then
begin
// not fully specialized
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.CheckSpecializeConstraints ',GetObjName(El),' i=',i,' P=',GetObjName(P),' ParamType=',GetObjName(ParamType));
{$ENDIF}
Result:=false;
// ToDo: check if both constraints fit
continue;
@ -14502,7 +14512,12 @@ begin
begin
if (ParentEl is TPasGenericType)
and (GetTypeParameterCount(TPasGenericType(ParentEl))>0) then
begin
{$IFDEF VerbosePasResolver}
//writeln('TPasResolver.CheckSpecializeConstraints El=',GetObjName(El),' not specialized Parent=',GetObjName(ParentEl));
{$ENDIF}
exit(false); // parent is not specialized
end;
ParentEl:=ParentEl.Parent;
end;
end;
@ -15064,17 +15079,12 @@ begin
if GenElType.Parent<>GenEl then
begin
// reference
if GenElType is TPasGenericTemplateType then
begin
Ref:=FindElement(GenElType.Name);
if (Ref<>GenElType) and (Ref is TPasType) then
begin
// replace template with specialized type
GenElType:=TPasType(Ref);
end;
end;
Ref:=FindElement(GenElType.Name);
if not (Ref is TPasType) then
RaiseNotYetImplemented(20190812021538,GenEl,GetObjName(Ref));
GenElType:=TPasType(Ref);
if SpecElType<>nil then
SpecElType.Release{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF};
RaiseNotYetImplemented(20190812021617,GenEl);
SpecElType:=GenElType;
SpecElType.AddRef{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF};
exit;
@ -15137,7 +15147,7 @@ procedure TPasResolver.SpecializeElList(GenEl, SpecEl: TPasElement;
{$IFDEF CheckPasTreeRefCount}; const RefId: string{$ENDIF});
var
i: Integer;
GenListItem, SpecListItem: TPasElement;
GenListItem, SpecListItem, Ref: TPasElement;
NewClass: TPTreeElement;
begin
for i:=0 to GenList.Count-1 do
@ -15147,9 +15157,14 @@ begin
begin
if not AllowReferences then
RaiseNotYetImplemented(20190808212421,GenEl,IntToStr(i));
if not (GenListItem is TPasType) then
RaiseNotYetImplemented(20190812025715,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem));
// reference
GenListItem.AddRef{$IFDEF CheckPasTreeRefCount}(RefID){$ENDIF};
SpecList.Add(GenListItem);
Ref:=FindElement(GenListItem.Name);
if not (Ref is TPasType) then
RaiseNotYetImplemented(20190812025715,GenEl,IntToStr(i)+' GenListItem='+GetObjName(GenListItem)+' Ref='+GetObjName(Ref));
Ref.AddRef{$IFDEF CheckPasTreeRefCount}(RefId){$ENDIF};
SpecList.Add(Ref);
continue;
end;
NewClass:=TPTreeElement(GenListItem.ClassType);
@ -15308,13 +15323,30 @@ end;
procedure TPasResolver.SpecializeSpecializeType(GenEl,
SpecEl: TPasSpecializeType);
var
GenDestType: TPasType;
Ref: TPasElement;
begin
SpecializeElType(GenEl,SpecEl,GenEl.DestType,SpecEl.DestType);
// search DestType<ParamCount>
GenDestType:=GenEl.DestType;
if GenDestType=nil then
RaiseNotYetImplemented(20190812022211,GenEl);
if GenDestType.Parent=GenEl then
RaiseNotYetImplemented(20190812022251,GenEl);
Ref:=FindElementFor(GenDestType.Name,GenEl.Parent,GenEl.Params.Count);
if not (Ref is TPasGenericType) then
RaiseNotYetImplemented(20190812022359,GenEl,GetObjName(Ref));
SpecEl.DestType:=TPasGenericType(Ref);
SpecEl.DestType.AddRef{$IFDEF CheckPasTreeRefCount}('ResolveTypeReference'){$ENDIF};
SpecializeElExpr(GenEl,SpecEl,GenEl.Expr,SpecEl.Expr);
SpecializeElList(GenEl,SpecEl,GenEl.Params,SpecEl.Params,true
{$IFDEF CheckPasTreeRefCount},'TPasSpecializeType.Params'{$ENDIF});
FinishSpecializeType(SpecEl);
{$IFDEF VerbosePasResolver}
//writeln('TPasResolver.SpecializeSpecializeType ',GetObjName(SpecEl.DestType),' ',GetObjName(SpecEl.CustomData));
{$ENDIF}
end;
procedure TPasResolver.SpecializeArgument(GenEl, SpecEl: TPasArgument);
@ -20528,7 +20560,7 @@ begin
for i:=0 to ProcArgs1.Count-1 do
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.CheckProcAssignCompatibility ',i,'/',ProcArgs1.Count);
writeln('TPasResolver.CheckProcTypeCompatibility ',i,'/',ProcArgs1.Count);
{$ENDIF}
ExpectedArg:=TPasArgument(ProcArgs1[i]);
ActualArg:=TPasArgument(ProcArgs2[i]);

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

@ -1525,10 +1525,17 @@ Var
K : TSimpleTypeKind;
Name : String;
Expr: TPasExpr;
ok: Boolean;
ok, MustBeSpecialize: Boolean;
begin
Result:=nil;
if CurToken=tkspecialize then
begin
MustBeSpecialize:=true;
ExpectIdentifier;
end
else
MustBeSpecialize:=false;
Name := CurTokenString;
Expr:=nil;
Ref:=nil;
@ -1547,6 +1554,9 @@ begin
end;
end;
if MustBeSpecialize and (CurToken<>tkLessThan) then
ParseExcTokenError('<');
// Current token is first token after identifier.
if IsFull and (CurToken=tkSemicolon) or isCurTokenHint then // Type A = B;
begin
@ -1719,8 +1729,7 @@ begin
ParseExcTokenError('[20190801113005]');
// ToDo: cascaded specialize A<B>.C<D>
if TypeName='' then
Engine.FinishScope(stTypeDef,ST);
Engine.FinishScope(stTypeDef,ST);
Result:=ST;
finally
if Result=nil then
@ -1841,10 +1850,7 @@ begin
tkInterface:
Result := ParseClassDecl(Parent, NamePos, TypeName, okInterface,PM);
tkSpecialize:
begin
NextToken;
Result:=ParseSimpleType(Parent,CurSourcePos,TypeName);
end;
tkClass:
begin
isHelper:=false;
@ -2096,7 +2102,7 @@ begin
{AllowWriteln}
if po_resolvestandardtypes in FOptions then
begin
writeln('ERROR: TPasParser.ParseSimpleType resolver failed to raise an error');
writeln('ERROR: TPasParser.ResolveTypeReference: resolver failed to raise an error');
ParseExcExpectedIdentifier;
end;
{AllowWriteln-}
@ -3520,33 +3526,33 @@ begin
// Scanner.SetForceCaret(OldForceCaret); // It may have been switched off
if Assigned(TypeEl) then // !!!
begin
Declarations.Declarations.Add(TypeEl);
{$IFDEF CheckPasTreeRefCount}if TypeEl.RefIds.IndexOf('CreateElement')>=0 then TypeEl.ChangeRefId('CreateElement','TPasDeclarations.Children');{$ENDIF}
if (TypeEl.ClassType = TPasClassType)
and (not (po_keepclassforward in Options)) then
Declarations.Declarations.Add(TypeEl);
{$IFDEF CheckPasTreeRefCount}if TypeEl.RefIds.IndexOf('CreateElement')>=0 then TypeEl.ChangeRefId('CreateElement','TPasDeclarations.Children');{$ENDIF}
if (TypeEl.ClassType = TPasClassType)
and (not (po_keepclassforward in Options)) then
begin
// Remove previous forward declarations, if necessary
for i := 0 to Declarations.Classes.Count - 1 do
begin
// Remove previous forward declarations, if necessary
for i := 0 to Declarations.Classes.Count - 1 do
ClassEl := TPasClassType(Declarations.Classes[i]);
if CompareText(ClassEl.Name, TypeEl.Name) = 0 then
begin
ClassEl := TPasClassType(Declarations.Classes[i]);
if CompareText(ClassEl.Name, TypeEl.Name) = 0 then
begin
Declarations.Classes.Delete(i);
for j := 0 to Declarations.Declarations.Count - 1 do
if CompareText(TypeEl.Name,
TPasElement(Declarations.Declarations[j]).Name) = 0 then
begin
Declarations.Declarations.Delete(j);
break;
end;
ClassEl.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
break;
end;
Declarations.Classes.Delete(i);
for j := 0 to Declarations.Declarations.Count - 1 do
if CompareText(TypeEl.Name,
TPasElement(Declarations.Declarations[j]).Name) = 0 then
begin
Declarations.Declarations.Delete(j);
break;
end;
ClassEl.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
break;
end;
// Add the new class to the class list
Declarations.Classes.Add(TypeEl)
end else
Declarations.Types.Add(TypeEl);
end;
// Add the new class to the class list
Declarations.Classes.Add(TypeEl)
end else
Declarations.Types.Add(TypeEl);
end;
end;
declExports:

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

@ -38,7 +38,6 @@ type
procedure TestGen_RecordDelphi;
procedure TestGen_RecordNestedSpecialized;
procedure TestGen_Record_SpecializeSelfInsideFail;
// ToDo: enums within generic
procedure TestGen_RecordAnoArray;
// ToDo: procedure TestGen_SpecializeArg_ArrayOf; type TBird = specialize<array of word>
// ToDo: unitname.specialize TBird<word>.specialize
@ -57,6 +56,9 @@ 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;
// ToDo: procedure TestGen_NestedDottedType;
procedure TestGen_Class_Enums_NotPropagating;
// generic external class
procedure TestGen_ExtClass_Array;
@ -78,15 +80,12 @@ type
// generic statements
procedure TestGen_LocalVar;
procedure TestGen_Statements;
procedure TestGen_ForLoop;
// ToDo: for-in
// ToDo: if
// ToDo: case
// ToDo: while, repeat
// ToDo: try finally/except
// ToDo: call
// ToDo: dot
// ToDo: is as
// ToDo: typecast
end;
implementation
@ -410,7 +409,7 @@ begin
' r: TRec;',
' end;',
'var',
' s: specialize TRec;',
' s: TRec;',
' {=Typ}w: T;',
'begin',
' s.b.v:=w;',
@ -502,6 +501,46 @@ begin
CheckResolverException('type "TBird" is not yet completely defined',nTypeXIsNotYetCompletelyDefined);
end;
procedure TTestResolveGenerics.TestGen_NestedType;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' generic TBird<T> = class',
' public type',
' TArrayEvent = reference to procedure(El: T);',
' public',
' p: TArrayEvent;',
' end;',
' TBirdWord = specialize TBird<word>;',
'var',
' b: TBirdWord;',
'begin',
' b.p:=procedure(El: word) begin end;']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_Class_Enums_NotPropagating;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' generic TBird<T> = class',
' public type',
' TEnum = (red, blue);',
' const',
' e = blue;',
' end;',
'const',
' r = red;',
'begin']);
CheckResolverException('identifier not found "red"',nIdentifierNotFound);
end;
procedure TTestResolveGenerics.TestGen_ExtClass_Array;
begin
StartProgram(false);
@ -516,11 +555,14 @@ begin
' procedure SetElements(Index: NativeInt; const AValue: T); external name ''[]'';',
' public',
' type TSelfType = TJSGenArray<T>;',
' TArrayEvent = reference to function(El: T; Arr: TSelfType): Boolean;',
' TArrayCallback = TArrayEvent;',
' public',
' FLength : NativeInt; external name ''length'';',
' constructor new; overload;',
' constructor new(aLength : NativeInt); overload;',
' class function _of() : TSelfType; varargs; external name ''of'';',
' function every(const aCallback: TArrayCallBack): boolean; overload;',
' function fill(aValue : T) : TSelfType; overload;',
' function fill(aValue : T; aStartIndex : NativeInt) : TSelfType; overload;',
' function fill(aValue : T; aStartIndex,aEndIndex : NativeInt) : TSelfType; overload;',
@ -541,6 +583,10 @@ begin
' wa.length:=10;',
' wa[11]:=w;',
' w:=wa[12];',
' wa.every(function(El: word; Arr: TJSWordArray): Boolean',
' begin',
' end',
' );',
'']);
ParseProgram;
end;
@ -627,29 +673,6 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_ForLoop;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TObject = class end;',
' generic TBird<{#Templ}T> = class',
' function Fly(p:T): T;',
' end;',
'function TBird.Fly(p:T): T;',
'var i: T;',
'begin',
' for i:=0 to 3 do Result:=i+p;',
'end;',
'var',
' b: specialize TBird<word>;',
'begin',
' b.Fly(2);',
'']);
ParseProgram;
end;
initialization
RegisterTests([TTestResolveGenerics]);