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

pastojs: fixed published field with anonymous array

Browse Source 
git-svn-id: trunk@49076 -
(cherry picked from commit a357645384)
This commit is contained in:
Mattias Gaertner 2021-03-28 21:41:22 +00:00 committed by Florian Klämpfl
parent 761d2c7551
commit 5c265c85b8
3 changed files with 213 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2387,6 +2387,7 @@ type
EvalLow: boolean; ErrorEl: TPasElement): TResEvalValue; virtual; // compute low() or high()
function EvalTypeRange(Decl: TPasType; Flags: TResEvalFlags): TResEvalValue; virtual; // compute low() and high()
function HasTypeInfo(El: TPasType): boolean; virtual;
function IsAnonymousElType(El: TPasType): boolean; virtual;
function GetActualBaseType(bt: TResolverBaseType): TResolverBaseType; virtual;
function GetCombinedBoolean(Bool1, Bool2: TResolverBaseType; ErrorEl: TPasElement): TResolverBaseType; virtual;
function GetCombinedInt(const Int1, Int2: TPasResolverResult; ErrorEl: TPasElement): TResolverBaseType; virtual;
@ -6236,15 +6237,26 @@ procedure TPasResolver.FinishSubElementType(Parent: TPasElement; El: TPasType);
{$IFDEF CheckPasTreeRefCount};const aId: string{$ENDIF});
var
i: Integer;
p: TPasElement;
p, Prev: TPasElement;
begin
p:=El.Parent;
if NewParent=p.Parent then
begin
// e.g. a:array of longint; -> insert a$a in front of a
// e.g. m,n:array of longint; -> insert n$a in front of m
i:=List.Count-1;
while (i>=0) and (List[i]<>Pointer(p)) do
dec(i);
if P is TPasVariable then
begin
while (i>0) do
begin
Prev:=TPasElement(List[i-1]);
if (Prev.ClassType=P.ClassType) and (TPasVariable(Prev).VarType=TPasVariable(P).VarType) then
dec(i) // e.g. m,n: array of longint
else
break;
end;
end;
if i<0 then
List.Add(El)
else
@ -29672,6 +29684,37 @@ begin
Result:=true;
end;
function TPasResolver.IsAnonymousElType(El: TPasType): boolean;
// e.g. b$a$a
var
aName: String;
i, l: SizeInt;
j: Integer;
begin
Result:=false;
if AnonymousElTypePostfix='' then exit;
aName:=El.Name;
l:=length(AnonymousElTypePostfix);
i:=length(aName);
repeat
dec(i,l);
if i>0 then
begin
j:=i;
while (j<=l) and (aName[i+j]=AnonymousElTypePostfix[j]) do inc(j);
if j>l then
begin
Result:=true;
continue;
end;
end;
if not Result then exit; // no postfix
// at least one anonymous eltype postfix
Result:=IsValidIdent(LeftStr(aName,i+l));
exit;
until false;
end;
function TPasResolver.GetActualBaseType(bt: TResolverBaseType
): TResolverBaseType;
begin

205
packages/pastojs/src/fppas2js.pp
View File

@ -2162,6 +2162,7 @@ type
Function CreateRTTIMemberProperty(Members: TFPList; Index: integer;
AContext: TConvertContext): TJSElement; virtual;
Procedure CreateRTTIAnonymous(El: TPasType; AContext: TConvertContext); virtual; // needed by precompiled files from 2.0.0
Function CreateRTTIAnonymousArray(El: TPasArrayType; AContext: TConvertContext): TJSCallExpression; virtual;
Function CreateRTTIMembers(El: TPasMembersType; Src: TJSSourceElements;
FuncContext: TFunctionContext; MembersSrc: TJSSourceElements;
MembersFuncContext: TFunctionContext; RTTIExpr: TJSElement;
@ -16631,19 +16632,13 @@ var
var
aResolver: TPas2JSResolver;
Scope: TPas2JSArrayScope;
SpecializeDelay: Boolean;
AssignSt: TJSSimpleAssignStatement;
CallName, ArrName: String;
Obj: TJSObjectLiteral;
Prop: TJSObjectLiteralElement;
ArrLit: TJSArrayLiteral;
Arr: TPasArrayType;
ArrName: String;
Index: Integer;
ElTypeHi, ElTypeLo: TPasType;
ElTypeLo: TPasType;
RangeEl: TPasExpr;
Call: TJSCallExpression;
RgLen, RangeEnd: TMaxPrecInt;
RangeEnd: TMaxPrecInt;
List: TJSStatementList;
Func: TJSFunctionDeclarationStatement;
BodySrc: TJSSourceElements;
@ -16666,9 +16661,6 @@ begin
writeln('TPasToJSConverter.ConvertArrayType ',GetObjName(El));
{$ENDIF}
Scope:=El.CustomData as TPas2JSArrayScope;
SpecializeDelay:=(Scope<>nil) and (SpecializeNeedsDelay(El,AContext));
ProcScope:=nil;
Src:=nil;
if AContext.JSElement is TJSSourceElements then
@ -16766,7 +16758,7 @@ begin
else
Result:=ArraySt;
// store precompiled enum type in proc
// store precompiled array type in proc
StorePrecompiledJS(ArraySt);
ArraySt:=nil;
@ -16778,52 +16770,12 @@ begin
end;
end;
if HasTypeInfo(El,AContext) then
if (not (AContext.PasElement is TPasMembersType)) // rtti of members is added separate
and HasTypeInfo(El,AContext) then
begin
// module.$rtti.$DynArray("name",{...})
if length(El.Ranges)>0 then
CallName:=GetBIName(pbifnRTTINewStaticArray)
else
CallName:=GetBIName(pbifnRTTINewDynArray);
Call:=CreateRTTINewType(El,CallName,false,AContext,Obj);
Call:=nil;
try
ElTypeHi:=aResolver.ResolveAliasType(El.ElType,false);
ElTypeLo:=aResolver.ResolveAliasType(ElTypeHi);
if length(El.Ranges)>0 then
begin
// static array
// dims: [dimsize1,dimsize2,...]
Prop:=Obj.Elements.AddElement;
Prop.Name:=TJSString(GetBIName(pbivnRTTIArray_Dims));
ArrLit:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,El));
Prop.Expr:=ArrLit;
Arr:=El;
Index:=0;
repeat
RangeEl:=Arr.Ranges[Index];
RgLen:=aResolver.GetRangeLength(RangeEl);
ArrLit.AddElement(CreateLiteralNumber(RangeEl,RgLen));
inc(Index);
if Index=length(Arr.Ranges) then
begin
if ElTypeLo.ClassType<>TPasArrayType then
break;
Arr:=TPasArrayType(ElTypeLo);
if length(Arr.Ranges)=0 then
RaiseNotSupported(Arr,AContext,20170411222315,'static array of anonymous array');
ElTypeHi:=aResolver.ResolveAliasType(Arr.ElType,false);
ElTypeLo:=aResolver.ResolveAliasType(ElTypeHi);
Index:=0;
end;
until false;
end;
// eltype: ref
if not SpecializeDelay then
begin
Prop:=Obj.Elements.AddElement;
Prop.Name:=TJSString(GetBIName(pbivnRTTIArray_ElType));
Prop.Expr:=CreateTypeInfoRef(ElTypeHi,AContext,El);
end;
Call:=CreateRTTIAnonymousArray(El,AContext);
if Src<>nil then
begin
@ -20132,6 +20084,7 @@ begin
JSTypeInfo:=CreateTypeInfoRef(VarType,AContext,V);
OptionsEl:=nil;
// Note: create JSTypeInfo first, it may raise an exception
Call:=CreateCallExpression(V);
try
@ -20477,6 +20430,80 @@ begin
end;
end;
function TPasToJSConverter.CreateRTTIAnonymousArray(El: TPasArrayType;
AContext: TConvertContext): TJSCallExpression;
var
Scope: TPas2JSArrayScope;
SpecializeDelay: Boolean;
CallName: String;
Call: TJSCallExpression;
Obj: TJSObjectLiteral;
aResolver: TPas2JSResolver;
ElTypeHi, ElTypeLo: TPasType;
Prop: TJSObjectLiteralElement;
ArrLit: TJSArrayLiteral;
Arr: TPasArrayType;
Index: Integer;
RangeEl: TPasExpr;
RgLen: TMaxPrecInt;
begin
Result:=nil;
aResolver:=AContext.Resolver;
Scope:=El.CustomData as TPas2JSArrayScope;
SpecializeDelay:=(Scope<>nil) and (SpecializeNeedsDelay(El,AContext));
// module.$rtti.$DynArray("name",{...})
if length(El.Ranges)>0 then
CallName:=GetBIName(pbifnRTTINewStaticArray)
else
CallName:=GetBIName(pbifnRTTINewDynArray);
Call:=CreateRTTINewType(El,CallName,false,AContext,Obj);
try
ElTypeHi:=aResolver.ResolveAliasType(El.ElType,false);
ElTypeLo:=aResolver.ResolveAliasType(ElTypeHi);
if length(El.Ranges)>0 then
begin
// static array
// dims: [dimsize1,dimsize2,...]
Prop:=Obj.Elements.AddElement;
Prop.Name:=TJSString(GetBIName(pbivnRTTIArray_Dims));
ArrLit:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,El));
Prop.Expr:=ArrLit;
Arr:=El;
Index:=0;
repeat
RangeEl:=Arr.Ranges[Index];
RgLen:=aResolver.GetRangeLength(RangeEl);
ArrLit.AddElement(CreateLiteralNumber(RangeEl,RgLen));
inc(Index);
if Index=length(Arr.Ranges) then
begin
if ElTypeLo.ClassType<>TPasArrayType then
break;
Arr:=TPasArrayType(ElTypeLo);
if length(Arr.Ranges)=0 then
RaiseNotSupported(Arr,AContext,20170411222315,'static array of anonymous array');
ElTypeHi:=aResolver.ResolveAliasType(Arr.ElType,false);
ElTypeLo:=aResolver.ResolveAliasType(ElTypeHi);
Index:=0;
end;
until false;
end;
// eltype: ref
if not SpecializeDelay then
begin
Prop:=Obj.Elements.AddElement;
Prop.Name:=TJSString(GetBIName(pbivnRTTIArray_ElType));
Prop.Expr:=CreateTypeInfoRef(ElTypeHi,AContext,El);
end;
Result:=Call;
finally
if Result=nil then
Call.Free;
end;
end;
function TPasToJSConverter.CreateRTTIMembers(El: TPasMembersType;
Src: TJSSourceElements; FuncContext: TFunctionContext;
MembersSrc: TJSSourceElements; MembersFuncContext: TFunctionContext;
@ -20532,35 +20559,51 @@ begin
Members:=El.Members;
For i:=0 to Members.Count-1 do
begin
NewEl:=nil;
P:=TPasElement(Members[i]);
C:=P.ClassType;
// check visibility
case mt of
mtClass:
if P.Visibility<>visPublished then continue;
mtInterface: ; // all members of an interface are published
mtRecord:
// a published record publishes all non private members
if P.Visibility in [visPrivate,visStrictPrivate] then
continue;
end;
if not IsElementUsed(P) then continue;
NewEl:=nil;
if C=TPasVariable then
NewEl:=CreateRTTIMemberField(Members,i,MembersFuncContext)
else if C.InheritsFrom(TPasProcedure) then
writeln('AAA1 TPasToJSConverter.CreateRTTIMembers ',GetObjPath(P));
if C.InheritsFrom(TPasType) and HasTypeInfo(TPasType(P),MembersFuncContext) then
begin
if aResolver.GetProcTemplateTypes(TPasProcedure(P))<>nil then
continue; // parametrized functions cannot be published
NewEl:=CreateRTTIMemberMethod(Members,i,MembersFuncContext);
writeln('AAA2 TPasToJSConverter.CreateRTTIMembers ',GetObjPath(P));
// published subtype
if aResolver.IsAnonymousElType(TPasType(P)) then
begin
// published anonymous eltype
writeln('AAA3 TPasToJSConverter.CreateRTTIMembers ',GetObjPath(P));
if C.InheritsFrom(TPasArrayType) then
NewEl:=CreateRTTIAnonymousArray(TPasArrayType(P),MembersFuncContext);
end;
end
else if C=TPasProperty then
NewEl:=CreateRTTIMemberProperty(Members,i,MembersFuncContext)
else if C.InheritsFrom(TPasType)
or (C=TPasAttributes) then
else
DoError(20190105142236,nSymbolCannotBePublished,sSymbolCannotBePublished,[],P);
begin
// check visibility
case mt of
mtClass:
if P.Visibility<>visPublished then continue;
mtInterface: ; // all members of an interface are published
mtRecord:
// a published record publishes all non private members
if P.Visibility in [visPrivate,visStrictPrivate] then
continue;
end;
if not IsElementUsed(P) then continue;
if C=TPasVariable then
NewEl:=CreateRTTIMemberField(Members,i,MembersFuncContext)
else if C.InheritsFrom(TPasProcedure) then
begin
if aResolver.GetProcTemplateTypes(TPasProcedure(P))<>nil then
continue; // parametrized functions cannot be published
NewEl:=CreateRTTIMemberMethod(Members,i,MembersFuncContext);
end
else if C=TPasProperty then
NewEl:=CreateRTTIMemberProperty(Members,i,MembersFuncContext)
else if C.InheritsFrom(TPasType)
or (C=TPasAttributes) then
else
DoError(20190105142236,nSymbolCannotBePublished,sSymbolCannotBePublished,[],P);
end;
if NewEl=nil then
continue; // e.g. abstract or external proc
// add RTTI element

50
packages/pastojs/tests/tcmodules.pas
View File

@ -829,6 +829,7 @@ type
Procedure TestRTTI_Class_PropertyParams;
Procedure TestRTTI_Class_OtherUnit_TypeAlias;
Procedure TestRTTI_Class_OmitRTTI;
Procedure TestRTTI_Class_Field_AnonymousArrayOfSelfClass;
Procedure TestRTTI_IndexModifier;
Procedure TestRTTI_StoredModifier;
Procedure TestRTTI_DefaultValue;
@ -29679,9 +29680,6 @@ begin
CheckSource('TestRTTI_Class_Field',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' $mod.$rtti.$DynArray("TObject.ArrB$a", {',
' eltype: rtl.byte',
' });',
' this.$init = function () {',
' this.FPropA = "";',
' this.VarLI = 0;',
@ -29713,6 +29711,9 @@ begin
' $r.addField("VarShI", rtl.shortint);',
' $r.addField("VarBy", rtl.byte);',
' $r.addField("VarExt", rtl.longint);',
' $mod.$rtti.$DynArray("TObject.ArrB$a", {',
' eltype: rtl.byte',
' });',
' $r.addField("ArrA", $mod.$rtti["TObject.ArrB$a"]);',
' $r.addField("ArrB", $mod.$rtti["TObject.ArrB$a"]);',
'});',
@ -29982,6 +29983,43 @@ begin
'']));
end;
procedure TTestModule.TestRTTI_Class_Field_AnonymousArrayOfSelfClass;
begin
WithTypeInfo:=true;
StartUnit(true,[supTObject]);
Add([
'interface',
'type',
' {$M+1}',
' TBird = class',
' published',
' Swarm: array of TBird;',
' end;',
'implementation',
'']);
ConvertUnit;
CheckSource('TestRTTI_Class_Field_AnonymousArrayOfSelfClass',
LinesToStr([ // statements
'rtl.createClass(this, "TBird", pas.system.TObject, function () {',
' this.$init = function () {',
' pas.system.TObject.$init.call(this);',
' this.Swarm = [];',
' };',
' this.$final = function () {',
' this.Swarm = undefined;',
' pas.system.TObject.$final.call(this);',
' };',
' var $r = this.$rtti;',
' $mod.$rtti.$DynArray("TBird.Swarm$a", {',
' eltype: $r',
' });',
' $r.addField("Swarm", $mod.$rtti["TBird.Swarm$a"]);',
'});',
'']),
LinesToStr([ // $mod.$main
'']));
end;
procedure TTestModule.TestRTTI_IndexModifier;
begin
WithTypeInfo:=true;
@ -30747,9 +30785,6 @@ begin
CheckSource('TestRTTI_Record',
LinesToStr([ // statements
'rtl.recNewT(this, "TFloatRec", function () {',
' $mod.$rtti.$DynArray("TFloatRec.d$a", {',
' eltype: rtl.char',
' });',
' this.$new = function () {',
' var r = Object.create(this);',
' r.c = [];',
@ -30765,6 +30800,9 @@ begin
' return this;',
' };',
' var $r = $mod.$rtti.$Record("TFloatRec", {});',
' $mod.$rtti.$DynArray("TFloatRec.d$a", {',
' eltype: rtl.char',
' });',
' $r.addField("c", $mod.$rtti["TFloatRec.d$a"]);',
' $r.addField("d", $mod.$rtti["TFloatRec.d$a"]);',
'});',