mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-08 10:48:12 +02:00
pastojs: create local record types in global scope
git-svn-id: trunk@40691 -
This commit is contained in:
Mattias Gaertner
parent
f465826ba9
commit
3c9a5e5602
@ -262,8 +262,7 @@ type
|
||||
procedure UseProcedure(Proc: TPasProcedure); virtual;
|
||||
procedure UseProcedureType(ProcType: TPasProcedureType; Mark: boolean); virtual;
|
||||
procedure UseType(El: TPasType; Mode: TPAUseMode); virtual;
|
||||
procedure UseRecordType(El: TPasRecordType; Mode: TPAUseMode); virtual;
|
||||
procedure UseClassType(El: TPasClassType; Mode: TPAUseMode); virtual;
|
||||
procedure UseClassOrRecType(El: TPasMembersType; Mode: TPAUseMode); virtual;
|
||||
procedure UseVariable(El: TPasVariable; Access: TResolvedRefAccess;
|
||||
UseFull: boolean); virtual;
|
||||
procedure UseResourcestring(El: TPasResString); virtual;
|
||||
@ -1178,7 +1177,7 @@ begin
|
||||
UseInitFinal(aModule.FinalizationSection);
|
||||
ModScope:=aModule.CustomData as TPasModuleScope;
|
||||
if ModScope.RangeErrorClass<>nil then
|
||||
UseClassType(ModScope.RangeErrorClass,paumElement);
|
||||
UseClassOrRecType(ModScope.RangeErrorClass,paumElement);
|
||||
if ModScope.RangeErrorConstructor<>nil then
|
||||
UseProcedure(ModScope.RangeErrorConstructor);
|
||||
|
||||
@ -1815,10 +1814,8 @@ begin
|
||||
{$IFDEF VerbosePasAnalyzer}
|
||||
writeln('TPasAnalyzer.UseType searching exports in ',GetElModName(El),' ...');
|
||||
{$ENDIF}
|
||||
if C=TPasRecordType then
|
||||
UseRecordType(TPasRecordType(El),Mode)
|
||||
else if C=TPasClassType then
|
||||
UseClassType(TPasClassType(El),Mode);
|
||||
if (C=TPasRecordType) or (C=TPasClassType) then
|
||||
UseClassOrRecType(TPasMembersType(El),Mode);
|
||||
end
|
||||
else
|
||||
begin
|
||||
@ -1848,10 +1845,8 @@ begin
|
||||
UseExpr(TPasArrayType(El).Ranges[i]);
|
||||
UseElType(El,TPasArrayType(El).ElType,Mode);
|
||||
end
|
||||
else if C=TPasRecordType then
|
||||
UseRecordType(TPasRecordType(El),Mode)
|
||||
else if C=TPasClassType then
|
||||
UseClassType(TPasClassType(El),Mode)
|
||||
else if (C=TPasRecordType) or (C=TPasClassType) then
|
||||
UseClassOrRecType(TPasMembersType(El),Mode)
|
||||
else if C=TPasEnumType then
|
||||
begin
|
||||
if not MarkElementAsUsed(El) then exit;
|
||||
@ -1883,22 +1878,7 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPasAnalyzer.UseRecordType(El: TPasRecordType; Mode: TPAUseMode);
|
||||
// called by UseType
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
if Mode=paumAllExports then exit;
|
||||
MarkElementAsUsed(El);
|
||||
if not ElementVisited(El,Mode) then
|
||||
begin
|
||||
if (Mode=paumAllPasUsable) or Resolver.IsTGUID(El) then
|
||||
for i:=0 to El.Members.Count-1 do
|
||||
UseVariable(TObject(El.Members[i]) as TPasVariable,rraNone,true);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPasAnalyzer.UseClassType(El: TPasClassType; Mode: TPAUseMode);
|
||||
procedure TPasAnalyzer.UseClassOrRecType(El: TPasMembersType; Mode: TPAUseMode);
|
||||
// called by UseType
|
||||
|
||||
procedure UseDelegations;
|
||||
@ -1936,7 +1916,7 @@ procedure TPasAnalyzer.UseClassType(El: TPasClassType; Mode: TPAUseMode);
|
||||
Map:=TPasClassIntfMap(o);
|
||||
repeat
|
||||
if Map.Intf<>nil then
|
||||
UseClassType(TPasClassType(Map.Intf),paumElement);
|
||||
UseClassOrRecType(TPasClassType(Map.Intf),paumElement);
|
||||
if Map.Procs<>nil then
|
||||
for j:=0 to Map.Procs.Count-1 do
|
||||
UseProcedure(TPasProcedure(Map.Procs[j]));
|
||||
@ -1960,6 +1940,7 @@ var
|
||||
o: TObject;
|
||||
Map: TPasClassIntfMap;
|
||||
ImplProc, IntfProc: TPasProcedure;
|
||||
aClass: TPasClassType;
|
||||
begin
|
||||
FirstTime:=true;
|
||||
case Mode of
|
||||
@ -1982,35 +1963,54 @@ begin
|
||||
{$IFDEF VerbosePasAnalyzer}
|
||||
writeln('TPasAnalyzer.UseClassType ',GetElModName(El),' ',Mode,' First=',FirstTime);
|
||||
{$ENDIF}
|
||||
if El.IsForward then
|
||||
begin
|
||||
Ref:=El.CustomData as TResolvedReference;
|
||||
UseClassType(Ref.Declaration as TPasClassType,Mode);
|
||||
exit;
|
||||
end;
|
||||
|
||||
ClassScope:=El.CustomData as TPasClassScope;
|
||||
if ClassScope=nil then
|
||||
exit; // ClassScope can be nil if msIgnoreInterfaces
|
||||
|
||||
aClass:=nil;
|
||||
ClassScope:=nil;
|
||||
IsCOMInterfaceRoot:=false;
|
||||
if FirstTime then
|
||||
|
||||
if El is TPasClassType then
|
||||
begin
|
||||
UseElType(El,ClassScope.DirectAncestor,paumElement);
|
||||
UseElType(El,El.HelperForType,paumElement);
|
||||
UseExpr(El.GUIDExpr);
|
||||
// El.Interfaces: using a class does not use automatically the interfaces
|
||||
if El.ObjKind=okInterface then
|
||||
aClass:=TPasClassType(El);
|
||||
if aClass.IsForward then
|
||||
begin
|
||||
UseDelegations;
|
||||
if (El.InterfaceType=citCom) and (El.AncestorType=nil) then
|
||||
IsCOMInterfaceRoot:=true;
|
||||
Ref:=aClass.CustomData as TResolvedReference;
|
||||
UseClassOrRecType(Ref.Declaration as TPasClassType,Mode);
|
||||
exit;
|
||||
end;
|
||||
if (El.ObjKind=okClass) and (ScopeModule<>nil)
|
||||
and (ClassScope.Interfaces<>nil) then
|
||||
// when checking a single unit, mark all method+properties implementing the interfaces
|
||||
MarkAllInterfaceImplementations(ClassScope);
|
||||
end;
|
||||
|
||||
ClassScope:=aClass.CustomData as TPasClassScope;
|
||||
if ClassScope=nil then
|
||||
exit; // ClassScope can be nil if msIgnoreInterfaces
|
||||
|
||||
if FirstTime then
|
||||
begin
|
||||
UseElType(El,ClassScope.DirectAncestor,paumElement);
|
||||
UseElType(El,aClass.HelperForType,paumElement);
|
||||
UseExpr(aClass.GUIDExpr);
|
||||
// aClass.Interfaces: using a class does not use automatically the interfaces
|
||||
if aClass.ObjKind=okInterface then
|
||||
begin
|
||||
UseDelegations;
|
||||
if (aClass.InterfaceType=citCom) and (aClass.AncestorType=nil) then
|
||||
IsCOMInterfaceRoot:=true;
|
||||
end;
|
||||
if (aClass.ObjKind=okClass) and (ScopeModule<>nil)
|
||||
and (ClassScope.Interfaces<>nil) then
|
||||
// when checking a single unit, mark all method+properties implementing the interfaces
|
||||
MarkAllInterfaceImplementations(ClassScope);
|
||||
end;
|
||||
end
|
||||
else if El is TPasRecordType then
|
||||
begin
|
||||
if (Mode<>paumAllPasUsable) and Resolver.IsTGUID(TPasRecordType(El)) then
|
||||
for i:=0 to El.Members.Count-1 do
|
||||
begin
|
||||
Member:=TPasElement(El.Members[i]);
|
||||
if Member is TPasVariable then
|
||||
UseVariable(TPasVariable(Member),rraNone,true);
|
||||
end;
|
||||
end
|
||||
else
|
||||
RaiseNotSupported(20181229103139,El);
|
||||
|
||||
// members
|
||||
AllPublished:=(Mode<>paumAllExports);
|
||||
@ -2074,11 +2074,11 @@ begin
|
||||
UseTypeInfo(Member);
|
||||
end
|
||||
else
|
||||
; // else: class is in unit interface, mark all non private members
|
||||
; // else: class/record is in unit interface, mark all non private members
|
||||
UseElement(Member,rraNone,true);
|
||||
end;
|
||||
|
||||
if FirstTime then
|
||||
if FirstTime and (ClassScope<>nil) then
|
||||
begin
|
||||
// method resolution
|
||||
List:=ClassScope.Interfaces;
|
||||
@ -2090,7 +2090,7 @@ begin
|
||||
begin
|
||||
// interface delegation
|
||||
// Note: This class is used. When the intftype is used, this delegation is used.
|
||||
AddOverride(TPasType(El.Interfaces[i]),TPasProperty(o));
|
||||
AddOverride(TPasType(aClass.Interfaces[i]),TPasProperty(o));
|
||||
end
|
||||
else if o is TPasClassIntfMap then
|
||||
begin
|
||||
@ -2111,7 +2111,7 @@ begin
|
||||
end;
|
||||
end
|
||||
else
|
||||
RaiseNotSupported(20180328224632,El,GetObjName(o));
|
||||
RaiseNotSupported(20180328224632,aClass,GetObjName(o));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -1206,6 +1206,7 @@ type
|
||||
procedure InternalAdd(Item: TPasIdentifier);
|
||||
procedure OnClearHashItem(Item, Dummy: pointer);
|
||||
protected
|
||||
// overloads: fix name clashes in JS
|
||||
FOverloadScopes: TFPList; // list of TPasIdentifierScope
|
||||
function HasOverloadIndex(El: TPasElement; WithElevatedLocal: boolean = false): boolean; virtual;
|
||||
function GetOverloadIndex(Identifier: TPasIdentifier;
|
||||
@ -1219,7 +1220,8 @@ type
|
||||
procedure RenameSubOverloads(Declarations: TFPList);
|
||||
procedure PushOverloadScope(Scope: TPasIdentifierScope);
|
||||
procedure PopOverloadScope;
|
||||
procedure AddType(El: TPasType); override;
|
||||
protected
|
||||
procedure AddRecordType(El: TPasRecordType); override;
|
||||
procedure ResolveImplAsm(El: TPasImplAsmStatement); override;
|
||||
procedure ResolveNameExpr(El: TPasExpr; const aName: string;
|
||||
Access: TResolvedRefAccess); override;
|
||||
@ -1245,6 +1247,7 @@ type
|
||||
function AddExternalName(const aName: string; El: TPasElement): TPasIdentifier; virtual;
|
||||
function FindExternalName(const aName: String): TPasIdentifier; virtual;
|
||||
procedure AddExternalPath(aName: string; El: TPasElement);
|
||||
procedure AddElevatedLocal(El: TPasElement); virtual;
|
||||
procedure ClearElementData; virtual;
|
||||
function GenerateGUID(El: TPasClassType): string; virtual;
|
||||
protected
|
||||
@ -1697,8 +1700,7 @@ type
|
||||
Function CreateRTTIClassField(V: TPasVariable; AContext: TConvertContext): TJSElement; virtual;
|
||||
Function CreateRTTIClassMethod(Proc: TPasProcedure; AContext: TConvertContext): TJSElement; virtual;
|
||||
Function CreateRTTIClassProperty(Prop: TPasProperty; AContext: TConvertContext): TJSElement; virtual;
|
||||
Procedure CreateRTTIAnonymous(El: TPasType; AContext: TConvertContext;
|
||||
var First, Last: TJSStatementList); virtual;
|
||||
Procedure CreateRTTIAnonymous(El: TPasType; AContext: TConvertContext); virtual;
|
||||
// create elements for interfaces
|
||||
Procedure AddIntfDelegations(ClassEl: TPasElement; Prop: TPasProperty;
|
||||
FinishedGUIDs: TStringList; ObjLit: TJSObjectLiteral; aContext: TFunctionContext);
|
||||
@ -2499,6 +2501,11 @@ begin
|
||||
if TPasClassType(El).IsForward then
|
||||
exit(false);
|
||||
end
|
||||
else if C=TPasRecordType then
|
||||
begin
|
||||
if (not WithElevatedLocal) and (El.Parent is TProcedureBody) then
|
||||
exit(false); // local record counted via TPas2JSSectionScope.FElevatedLocals
|
||||
end
|
||||
else if C.InheritsFrom(TPasProcedure) then
|
||||
begin
|
||||
if TPasProcedure(El).IsOverride then
|
||||
@ -2592,7 +2599,8 @@ begin
|
||||
Scope:=TPasIdentifierScope(FOverloadScopes[i]);
|
||||
if (Scope.ClassType=TPas2JSSectionScope) and (i<FOverloadScopes.Count-1) then
|
||||
begin
|
||||
// Note: the elevated locals are after the section scope and before the next deeper scope
|
||||
// Note: the elevated locals have their index after the section scope and
|
||||
// before the next deeper scope
|
||||
|
||||
// check elevated locals
|
||||
Identifier:=TPas2JSSectionScope(Scope).FindElevatedLocal(El.Name);
|
||||
@ -2609,14 +2617,12 @@ begin
|
||||
end;
|
||||
inc(Result,j);
|
||||
end;
|
||||
// find last added
|
||||
// add count or index of this scope
|
||||
Identifier:=Scope.FindLocalIdentifier(El.Name);
|
||||
// add count or index
|
||||
inc(Result,GetOverloadIndex(Identifier,El));
|
||||
end;
|
||||
// find in external names
|
||||
// finally add count or index of the external scope
|
||||
Identifier:=FindExternalName(El.Name);
|
||||
// add count or index
|
||||
inc(Result,GetOverloadIndex(Identifier,El));
|
||||
end;
|
||||
|
||||
@ -2734,13 +2740,15 @@ var
|
||||
El: TPasElement;
|
||||
Proc: TPasProcedure;
|
||||
ProcScope, OvrProcScope, ImplProcScope: TPas2JSProcedureScope;
|
||||
C: TClass;
|
||||
begin
|
||||
//IsExternalClass:=(DeclEl is TPasClassType) and (TPasClassType(DeclEl).IsExternal);
|
||||
if DeclEl=nil then;
|
||||
for i:=0 to Declarations.Count-1 do
|
||||
begin
|
||||
El:=TPasElement(Declarations[i]);
|
||||
if (El is TPasProcedure) then
|
||||
C:=El.ClassType;
|
||||
if C.InheritsFrom(TPasProcedure) then
|
||||
begin
|
||||
Proc:=TPasProcedure(El);
|
||||
ProcScope:=Proc.CustomData as TPas2JSProcedureScope;
|
||||
@ -2772,7 +2780,16 @@ begin
|
||||
end;
|
||||
// proc declaration (header, not body)
|
||||
RenameOverload(Proc);
|
||||
end;
|
||||
end
|
||||
else if (C=TPasClassType) or (C=TPasRecordType) then
|
||||
begin
|
||||
if El.Parent is TProcedureBody then
|
||||
RenameOverload(El);
|
||||
end
|
||||
else if C=TPasConst then
|
||||
RenameOverload(El)
|
||||
else if C.InheritsFrom(TPasVariable) and (El.Parent.ClassType=TPasClassType) then
|
||||
RenameOverload(El);
|
||||
end;
|
||||
{$IFDEF VerbosePas2JS}
|
||||
//writeln('TPas2JSResolver.RenameOverloads END ',GetObjName(DeclEl));
|
||||
@ -2798,7 +2815,7 @@ begin
|
||||
Proc:=TPasProcedure(El);
|
||||
ProcScope:=Proc.CustomData as TPasProcedureScope;
|
||||
{$IFDEF VerbosePas2JS}
|
||||
writeln('TPas2JSResolver.RenameSubOverloads Proc=',Proc.Name,' DeclarationProc=',GetObjName(ProcScope.DeclarationProc),' ImplProc=',GetObjName(ProcScope.ImplProc),' ClassScope=',GetObjName(ProcScope.ClassScope));
|
||||
//writeln('TPas2JSResolver.RenameSubOverloads Proc=',Proc.Name,' DeclarationProc=',GetObjName(ProcScope.DeclarationProc),' ImplProc=',GetObjName(ProcScope.ImplProc),' ClassScope=',GetObjName(ProcScope.ClassScope));
|
||||
{$ENDIF}
|
||||
if Proc.Body<>nil then
|
||||
begin
|
||||
@ -2810,32 +2827,36 @@ begin
|
||||
PopOverloadScope;
|
||||
end;
|
||||
end
|
||||
else if C=TPasClassType then
|
||||
else if (C=TPasClassType) or (C=TPasRecordType) then
|
||||
begin
|
||||
ClassEl:=TPasClassType(El);
|
||||
if ClassEl.IsForward then continue;
|
||||
ClassScope:=El.CustomData as TPas2JSClassScope;
|
||||
OldScopeCount:=FOverloadScopes.Count;
|
||||
|
||||
// add class and ancestor scopes
|
||||
aScope:=ClassScope;
|
||||
repeat
|
||||
PushOverloadScope(aScope);
|
||||
aScope:=aScope.AncestorScope;
|
||||
until aScope=nil;
|
||||
if C=TPasClassType then
|
||||
begin
|
||||
ClassEl:=TPasClassType(El);
|
||||
if ClassEl.IsForward then continue;
|
||||
ClassScope:=El.CustomData as TPas2JSClassScope;
|
||||
// add class and ancestor scopes
|
||||
aScope:=ClassScope;
|
||||
repeat
|
||||
PushOverloadScope(aScope);
|
||||
aScope:=aScope.AncestorScope;
|
||||
until aScope=nil;
|
||||
end
|
||||
else
|
||||
begin
|
||||
// add record scope
|
||||
PushOverloadScope(TPasRecordType(El).CustomData as TPasRecordScope);
|
||||
end;
|
||||
|
||||
// first rename all overloads on this level
|
||||
RenameOverloads(ClassEl,ClassEl.Members);
|
||||
RenameOverloads(El,TPasMembersType(El).Members);
|
||||
// then process nested procedures
|
||||
RenameSubOverloads(ClassEl.Members);
|
||||
RenameSubOverloads(TPasMembersType(El).Members);
|
||||
|
||||
// restore scope
|
||||
while FOverloadScopes.Count>OldScopeCount do
|
||||
PopOverloadScope;
|
||||
end
|
||||
else if C=TPasConst then
|
||||
RenameOverload(El)
|
||||
else if C.InheritsFrom(TPasVariable) and (El.Parent.ClassType=TPasClassType) then
|
||||
RenameOverload(El);
|
||||
end;
|
||||
end;
|
||||
{$IFDEF VerbosePas2JS}
|
||||
//writeln('TPas2JSResolver.RenameSubOverloads END');
|
||||
@ -2852,9 +2873,12 @@ begin
|
||||
FOverloadScopes.Delete(FOverloadScopes.Count-1);
|
||||
end;
|
||||
|
||||
procedure TPas2JSResolver.AddType(El: TPasType);
|
||||
procedure TPas2JSResolver.AddRecordType(El: TPasRecordType);
|
||||
begin
|
||||
inherited AddType(El);
|
||||
inherited;
|
||||
if El.Parent is TProcedureBody then
|
||||
// local record
|
||||
AddElevatedLocal(El);
|
||||
end;
|
||||
|
||||
procedure TPas2JSResolver.ResolveImplAsm(El: TPasImplAsmStatement);
|
||||
@ -3307,8 +3331,6 @@ var
|
||||
AbsIdent: TPasElement;
|
||||
TypeEl, ElTypeEl: TPasType;
|
||||
GUID: TGUID;
|
||||
i: Integer;
|
||||
SectionScope: TPas2JSSectionScope;
|
||||
begin
|
||||
inherited FinishVariable(El);
|
||||
|
||||
@ -3389,12 +3411,7 @@ begin
|
||||
if (El.ClassType=TPasConst) and TPasConst(El).IsConst then
|
||||
begin
|
||||
// local const
|
||||
i:=ScopeCount-1;
|
||||
while (i>=0) and not (Scopes[i] is TPas2JSSectionScope) do dec(i);
|
||||
if i<0 then
|
||||
RaiseNotYetImplemented(20180420131358,El);
|
||||
SectionScope:=TPas2JSSectionScope(Scopes[i]);
|
||||
SectionScope.AddElevatedLocal(El.Name,El);
|
||||
AddElevatedLocal(El);
|
||||
end;
|
||||
end
|
||||
else if ParentC=TImplementationSection then
|
||||
@ -3846,6 +3863,19 @@ begin
|
||||
AddExternalName(LeftStr(aName,p-1),El);
|
||||
end;
|
||||
|
||||
procedure TPas2JSResolver.AddElevatedLocal(El: TPasElement);
|
||||
var
|
||||
i: Integer;
|
||||
SectionScope: TPas2JSSectionScope;
|
||||
begin
|
||||
i:=ScopeCount-1;
|
||||
while (i>=0) and not (Scopes[i] is TPas2JSSectionScope) do dec(i);
|
||||
if i<0 then
|
||||
RaiseNotYetImplemented(20180420131358,El);
|
||||
SectionScope:=TPas2JSSectionScope(Scopes[i]);
|
||||
SectionScope.AddElevatedLocal(El.Name,El);
|
||||
end;
|
||||
|
||||
procedure TPas2JSResolver.ClearElementData;
|
||||
var
|
||||
Data, Next: TPas2JsElementData;
|
||||
@ -7086,7 +7116,7 @@ var
|
||||
begin
|
||||
if PosEl=nil then PosEl:=El;
|
||||
CurName:=TransformVariableName(El,Name,false,AContext);
|
||||
if not (El.Parent is TProcedureBody) then
|
||||
if AContext.IsGlobal then
|
||||
begin
|
||||
ParentName:=AContext.GetLocalName(El.Parent);
|
||||
if ParentName='' then
|
||||
@ -15260,20 +15290,33 @@ begin
|
||||
end;
|
||||
|
||||
procedure TPasToJSConverter.CreateRTTIAnonymous(El: TPasType;
|
||||
AContext: TConvertContext; var First, Last: TJSStatementList);
|
||||
AContext: TConvertContext);
|
||||
// if El has any anonymous types, create the RTTI
|
||||
var
|
||||
C: TClass;
|
||||
JS: TJSElement;
|
||||
GlobalCtx: TFunctionContext;
|
||||
Src: TJSSourceElements;
|
||||
begin
|
||||
if El.Name<>'' then
|
||||
RaiseNotSupported(El,AContext,20170905162324,'inconsistency');
|
||||
|
||||
GlobalCtx:=AContext.GetGlobalFunc;
|
||||
if GlobalCtx=nil then
|
||||
RaiseNotSupported(El,AContext,20181229130835);
|
||||
if not (GlobalCtx.JSElement is TJSSourceElements) then
|
||||
begin
|
||||
{$IFDEF VerbosePas2JS}
|
||||
writeln('TPasToJSConverter.CreateRTTIAnonymous GlobalCtx=',GetObjName(GlobalCtx),' JSElement=',GetObjName(GlobalCtx.JSElement));
|
||||
{$ENDIF}
|
||||
RaiseNotSupported(El,AContext,20181229130926);
|
||||
end;
|
||||
Src:=TJSSourceElements(GlobalCtx.JSElement);
|
||||
C:=El.ClassType;
|
||||
if C=TPasArrayType then
|
||||
begin
|
||||
JS:=ConvertArrayType(TPasArrayType(El),AContext);
|
||||
AddToStatementList(First,Last,JS,El);
|
||||
AddToSourceElements(Src,JS);
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -19219,7 +19262,7 @@ Var
|
||||
AssignSt: TJSSimpleAssignStatement;
|
||||
Obj: TJSObjectLiteral;
|
||||
ObjLit: TJSObjectLiteralElement;
|
||||
ConstContext: TFunctionContext;
|
||||
GlobalCtx: TFunctionContext;
|
||||
C: TJSElement;
|
||||
V: TJSVariableStatement;
|
||||
Src: TJSSourceElements;
|
||||
@ -19234,15 +19277,15 @@ begin
|
||||
if not AContext.IsGlobal then
|
||||
begin
|
||||
// local const are stored in interface/implementation
|
||||
ConstContext:=AContext.GetGlobalFunc;
|
||||
if not (ConstContext.JSElement is TJSSourceElements) then
|
||||
GlobalCtx:=AContext.GetGlobalFunc;
|
||||
if not (GlobalCtx.JSElement is TJSSourceElements) then
|
||||
begin
|
||||
{$IFDEF VerbosePas2JS}
|
||||
writeln('TPasToJSConverter.CreateConstDecl ConstContext=',GetObjName(ConstContext),' JSElement=',GetObjName(ConstContext.JSElement));
|
||||
writeln('TPasToJSConverter.CreateConstDecl GlobalCtx=',GetObjName(GlobalCtx),' JSElement=',GetObjName(GlobalCtx.JSElement));
|
||||
{$ENDIF}
|
||||
RaiseNotSupported(El,AContext,20170220153216);
|
||||
end;
|
||||
Src:=TJSSourceElements(ConstContext.JSElement);
|
||||
Src:=TJSSourceElements(GlobalCtx.JSElement);
|
||||
C:=ConvertVariable(El,AContext);
|
||||
if C=nil then
|
||||
RaiseInconsistency(20180501114422,El);
|
||||
@ -19571,7 +19614,7 @@ const
|
||||
RetSt.Expr:=CreateLiteralBoolean(El,true);
|
||||
end;
|
||||
|
||||
procedure AddRTTIFields(Args: TJSArguments; var First, Last: TJSStatementList);
|
||||
procedure AddRTTIFields(Args: TJSArguments);
|
||||
var
|
||||
i: Integer;
|
||||
PasVar: TPasVariable;
|
||||
@ -19583,7 +19626,7 @@ const
|
||||
if not IsElementUsed(PasVar) then continue;
|
||||
VarType:=PasVar.VarType;
|
||||
if VarType.Name='' then
|
||||
CreateRTTIAnonymous(VarType,AContext,First,Last);
|
||||
CreateRTTIAnonymous(VarType,AContext);
|
||||
// add quoted "fieldname"
|
||||
Args.AddElement(CreateLiteralString(PasVar,TransformVariableName(PasVar,AContext)));
|
||||
// add typeinfo ref
|
||||
@ -19595,40 +19638,54 @@ var
|
||||
AssignSt: TJSSimpleAssignStatement;
|
||||
FDS: TJSFunctionDeclarationStatement;
|
||||
FD: TJSFuncDef;
|
||||
BodyFirst, BodyLast, ListFirst, ListLast: TJSStatementList;
|
||||
BodyFirst, BodyLast, ListFirst: TJSStatementList;
|
||||
FuncContext: TFunctionContext;
|
||||
GlobalCtx: TConvertContext;
|
||||
ObjLit: TJSObjectLiteral;
|
||||
IfSt: TJSIfStatement;
|
||||
Call, Call2: TJSCallExpression;
|
||||
ok: Boolean;
|
||||
Src: TJSSourceElements;
|
||||
Proc: TPasProcedure;
|
||||
ProcScope: TPas2JSProcedureScope;
|
||||
begin
|
||||
if El.Name='' then
|
||||
RaiseNotSupported(El,AContext,20181229133138,'anonymous record');
|
||||
Result:=nil;
|
||||
FuncContext:=nil;
|
||||
ListFirst:=nil;
|
||||
ListLast:=nil;
|
||||
Src:=nil;
|
||||
ok:=false;
|
||||
try
|
||||
FDS:=CreateFunctionSt(El);
|
||||
FD:=FDS.AFunction;
|
||||
// records are stored in interface/implementation
|
||||
GlobalCtx:=AContext;
|
||||
if El.Parent is TProcedureBody then
|
||||
begin
|
||||
// ToDo: elevate to non local scope
|
||||
// add 'function TypeName(){}'
|
||||
Result:=FDS;
|
||||
FD.Name:=TJSString(TransformVariableName(El,AContext));
|
||||
end
|
||||
else
|
||||
begin
|
||||
// add 'this.TypeName = function(){}'
|
||||
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
|
||||
Result:=AssignSt;
|
||||
AssignSt.LHS:=CreateSubDeclNameExpr(El,AContext);
|
||||
AssignSt.Expr:=FDS;
|
||||
GlobalCtx:=AContext.GetGlobalFunc;
|
||||
if not (GlobalCtx.JSElement is TJSSourceElements) then
|
||||
begin
|
||||
{$IFDEF VerbosePas2JS}
|
||||
writeln('TPasToJSConverter.ConvertRecordType GlobalCtx=',GetObjName(GlobalCtx),' JSElement=',GetObjName(GlobalCtx.JSElement));
|
||||
{$ENDIF}
|
||||
RaiseNotSupported(El,AContext,20181229142440);
|
||||
end;
|
||||
Src:=TJSSourceElements(GlobalCtx.JSElement);
|
||||
end;
|
||||
// add 'this.TypeName = function(){}'
|
||||
AssignSt:=TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El));
|
||||
AssignSt.LHS:=CreateSubDeclNameExpr(El,GlobalCtx);
|
||||
AssignSt.Expr:=FDS;
|
||||
if Src<>nil then
|
||||
AddToSourceElements(Src,AssignSt)
|
||||
else
|
||||
Result:=AssignSt;
|
||||
|
||||
// add param s
|
||||
FD.Params.Add(SrcParamName);
|
||||
// create function body
|
||||
FuncContext:=TFunctionContext.Create(El,FD.Body,AContext);
|
||||
FuncContext:=TFunctionContext.Create(El,FD.Body,GlobalCtx);
|
||||
FuncContext.ThisPas:=El;
|
||||
FuncContext.IsGlobal:=true;
|
||||
BodyFirst:=nil;
|
||||
@ -19650,16 +19707,14 @@ begin
|
||||
if FD.Body.A=nil then
|
||||
FD.Body.A:=BodyFirst;
|
||||
|
||||
if HasTypeInfo(El,AContext) then
|
||||
if HasTypeInfo(El,GlobalCtx) then
|
||||
begin
|
||||
// add $rtti as second statement
|
||||
if not (AContext is TFunctionContext) then
|
||||
RaiseNotSupported(El,AContext,20170412120012);
|
||||
if not (GlobalCtx is TFunctionContext) then
|
||||
RaiseNotSupported(El,GlobalCtx,20170412120012);
|
||||
|
||||
AddToStatementList(ListFirst,ListLast,Result,El);
|
||||
Result:=nil;
|
||||
// module.$rtti.$Record("typename",{});
|
||||
Call:=CreateRTTINewType(El,GetBIName(pbifnRTTINewRecord),false,AContext,ObjLit);
|
||||
Call:=CreateRTTINewType(El,GetBIName(pbifnRTTINewRecord),false,GlobalCtx,ObjLit);
|
||||
if ObjLit=nil then
|
||||
RaiseInconsistency(20170412124804,El);
|
||||
if El.Members.Count>0 then
|
||||
@ -19671,19 +19726,37 @@ begin
|
||||
Call2.Expr:=CreateDotExpression(El,Call,
|
||||
CreatePrimitiveDotExpr(GetBIName(pbifnRTTIAddFields),El));
|
||||
Call:=Call2;
|
||||
AddRTTIFields(Call.Args,ListFirst,ListLast);
|
||||
AddRTTIFields(Call.Args);
|
||||
end;
|
||||
if Src<>nil then
|
||||
// add Call to global statements
|
||||
AddToSourceElements(Src,Call)
|
||||
else
|
||||
begin
|
||||
// combine Result and Call into a statement list
|
||||
ListFirst:=TJSStatementList(CreateElement(TJSStatementList,El));
|
||||
ListFirst.A:=Result;
|
||||
ListFirst.B:=Call;
|
||||
Result:=ListFirst;
|
||||
ListFirst:=nil;
|
||||
end;
|
||||
|
||||
if (GlobalCtx<>AContext) and (coStoreImplJS in Options)
|
||||
and (AContext.Resolver<>nil) then
|
||||
begin
|
||||
// store precompiled record type in proc
|
||||
Proc:=AContext.Resolver.GetTopLvlProc(AContext.PasElement);
|
||||
if Proc<>nil then
|
||||
begin
|
||||
ProcScope:=TPas2JSProcedureScope(Proc.CustomData);
|
||||
ProcScope.AddGlobalJS(CreatePrecompiledJS(AssignSt));
|
||||
end;
|
||||
end;
|
||||
AddToStatementList(ListFirst,ListLast,Call,El);
|
||||
Result:=ListFirst;
|
||||
ListFirst:=nil;
|
||||
ListLast:=nil;
|
||||
end;
|
||||
ok:=true;
|
||||
finally
|
||||
FuncContext.Free;
|
||||
if ListFirst<>nil then
|
||||
FreeAndNil(ListFirst)
|
||||
else if not ok then
|
||||
if not ok then
|
||||
FreeAndNil(Result);
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -90,6 +90,7 @@ type
|
||||
procedure CheckRestoredPrimitiveExpr(const Path: string; Orig, Rest: TPrimitiveExpr); virtual;
|
||||
procedure CheckRestoredBoolConstExpr(const Path: string; Orig, Rest: TBoolConstExpr); virtual;
|
||||
procedure CheckRestoredParamsExpr(const Path: string; Orig, Rest: TParamsExpr); virtual;
|
||||
procedure CheckRestoredProcedureExpr(const Path: string; Orig, Rest: TProcedureExpr); virtual;
|
||||
procedure CheckRestoredRecordValues(const Path: string; Orig, Rest: TRecordValues); virtual;
|
||||
procedure CheckRestoredPasExprArray(const Path: string; Orig, Rest: TPasExprArray); virtual;
|
||||
procedure CheckRestoredArrayValues(const Path: string; Orig, Rest: TArrayValues); virtual;
|
||||
@ -140,6 +141,7 @@ type
|
||||
procedure TestPC_Set;
|
||||
procedure TestPC_SetOfAnonymousEnumType;
|
||||
procedure TestPC_Record;
|
||||
procedure TestPC_Record_Local;
|
||||
procedure TestPC_JSValue;
|
||||
procedure TestPC_Array;
|
||||
procedure TestPC_ArrayOfAnonymous;
|
||||
@ -149,6 +151,7 @@ type
|
||||
procedure TestPC_Proc_UTF8;
|
||||
procedure TestPC_Proc_Arg;
|
||||
procedure TestPC_ProcType;
|
||||
procedure TestPC_Proc_Anonymous;
|
||||
procedure TestPC_Class;
|
||||
procedure TestPC_ClassForward;
|
||||
procedure TestPC_ClassConstructor;
|
||||
@ -1078,6 +1081,8 @@ begin
|
||||
CheckRestoredPasExpr(Path,TPasExpr(Orig),TPasExpr(Rest))
|
||||
else if C=TParamsExpr then
|
||||
CheckRestoredParamsExpr(Path,TParamsExpr(Orig),TParamsExpr(Rest))
|
||||
else if C=TProcedureExpr then
|
||||
CheckRestoredProcedureExpr(Path,TProcedureExpr(Orig),TProcedureExpr(Rest))
|
||||
else if C=TRecordValues then
|
||||
CheckRestoredRecordValues(Path,TRecordValues(Orig),TRecordValues(Rest))
|
||||
else if C=TArrayValues then
|
||||
@ -1259,6 +1264,13 @@ begin
|
||||
CheckRestoredPasExpr(Path,Orig,Rest);
|
||||
end;
|
||||
|
||||
procedure TCustomTestPrecompile.CheckRestoredProcedureExpr(const Path: string;
|
||||
Orig, Rest: TProcedureExpr);
|
||||
begin
|
||||
CheckRestoredProcedure(Path+'$Ano',Orig.Proc,Rest.Proc);
|
||||
CheckRestoredPasExpr(Path,Orig,Rest);
|
||||
end;
|
||||
|
||||
procedure TCustomTestPrecompile.CheckRestoredRecordValues(const Path: string;
|
||||
Orig, Rest: TRecordValues);
|
||||
var
|
||||
@ -1691,6 +1703,28 @@ begin
|
||||
WriteReadUnit;
|
||||
end;
|
||||
|
||||
procedure TTestPrecompile.TestPC_Record_Local;
|
||||
begin
|
||||
StartUnit(false);
|
||||
Add([
|
||||
'interface',
|
||||
'procedure DoIt;',
|
||||
'implementation',
|
||||
'procedure DoIt;',
|
||||
'type',
|
||||
' TRec = record',
|
||||
' i: longint;',
|
||||
' s: string;',
|
||||
' end;',
|
||||
' P = ^TRec;',
|
||||
' TArrOfRec = array of TRec;',
|
||||
'var',
|
||||
' r: TRec;',
|
||||
'begin',
|
||||
'end;']);
|
||||
WriteReadUnit;
|
||||
end;
|
||||
|
||||
procedure TTestPrecompile.TestPC_JSValue;
|
||||
begin
|
||||
StartUnit(false);
|
||||
@ -1866,6 +1900,32 @@ begin
|
||||
WriteReadUnit;
|
||||
end;
|
||||
|
||||
procedure TTestPrecompile.TestPC_Proc_Anonymous;
|
||||
begin
|
||||
StartUnit(false);
|
||||
Add([
|
||||
'interface',
|
||||
'type',
|
||||
' TFunc = reference to function(w: word): word;',
|
||||
' function GetIt(f: TFunc): longint;',
|
||||
'implementation',
|
||||
'var k: byte;',
|
||||
'function GetIt(f: TFunc): longint;',
|
||||
'begin',
|
||||
' f:=function(w: word): word',
|
||||
' var j: byte;',
|
||||
' function GetMul(a,b: longint): longint; ',
|
||||
' begin',
|
||||
' Result:=a*b;',
|
||||
' end;',
|
||||
' begin',
|
||||
' Result:=j*GetMul(1,2)*k;',
|
||||
' end;',
|
||||
'end;',
|
||||
'']);
|
||||
WriteReadUnit;
|
||||
end;
|
||||
|
||||
procedure TTestPrecompile.TestPC_Class;
|
||||
begin
|
||||
StartUnit(false);
|
||||
|
||||
@ -431,7 +431,7 @@ type
|
||||
Procedure TestRecord_Empty;
|
||||
Procedure TestRecord_Var;
|
||||
Procedure TestRecord_VarExternal;
|
||||
Procedure TestWithRecordDo;
|
||||
Procedure TestRecord_WithDo;
|
||||
Procedure TestRecord_Assign;
|
||||
Procedure TestRecord_PassAsArgClone;
|
||||
Procedure TestRecord_AsParams;
|
||||
@ -445,6 +445,12 @@ type
|
||||
Procedure TestRecord_Const;
|
||||
Procedure TestRecord_TypecastFail;
|
||||
Procedure TestRecord_InFunction;
|
||||
// Test name clash const and local record
|
||||
// Test RTTI of local record
|
||||
// Test pcu local record, name clash and rtti
|
||||
|
||||
// advanced record
|
||||
// ToDo: TestRecord_InFunction;
|
||||
|
||||
// classes
|
||||
Procedure TestClass_TObjectDefaultConstructor;
|
||||
@ -9127,7 +9133,7 @@ begin
|
||||
]));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestWithRecordDo;
|
||||
procedure TTestModule.TestRecord_WithDo;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('type');
|
||||
@ -9760,6 +9766,7 @@ procedure TTestModule.TestRecord_InFunction;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'var TPoint: longint = 3;',
|
||||
'procedure DoIt;',
|
||||
'type',
|
||||
' TPoint = record x,y: longint; end;',
|
||||
@ -9774,22 +9781,23 @@ begin
|
||||
ConvertProgram;
|
||||
CheckSource('TestRecord_InFunction',
|
||||
LinesToStr([ // statements
|
||||
'this.DoIt = function () {',
|
||||
' function TPoint(s) {',
|
||||
' if (s) {',
|
||||
' this.x = s.x;',
|
||||
' this.y = s.y;',
|
||||
' } else {',
|
||||
' this.x = 0;',
|
||||
' this.y = 0;',
|
||||
' };',
|
||||
' this.$equal = function (b) {',
|
||||
' return (this.x === b.x) && (this.y === b.y);',
|
||||
' };',
|
||||
'this.TPoint = 3;',
|
||||
'this.TPoint$1 = function (s) {',
|
||||
' if (s) {',
|
||||
' this.x = s.x;',
|
||||
' this.y = s.y;',
|
||||
' } else {',
|
||||
' this.x = 0;',
|
||||
' this.y = 0;',
|
||||
' };',
|
||||
' var r = new TPoint();',
|
||||
' this.$equal = function (b) {',
|
||||
' return (this.x === b.x) && (this.y === b.y);',
|
||||
' };',
|
||||
'};',
|
||||
'this.DoIt = function () {',
|
||||
' var r = new TPoint$1();',
|
||||
' var p = [];',
|
||||
' p = rtl.arraySetLength(p, TPoint, 2);',
|
||||
' p = rtl.arraySetLength(p, TPoint$1, 2);',
|
||||
'};',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
@ -21857,6 +21865,9 @@ begin
|
||||
ConvertProgram;
|
||||
CheckSource('TestRTTI_Record',
|
||||
LinesToStr([ // statements
|
||||
'$mod.$rtti.$DynArray("TFloatRec.d$a", {',
|
||||
' eltype: rtl.char',
|
||||
'});',
|
||||
'this.TFloatRec = function (s) {',
|
||||
' if (s) {',
|
||||
' this.d = s.d;',
|
||||
@ -21867,9 +21878,6 @@ begin
|
||||
' return this.d === b.d;',
|
||||
' };',
|
||||
'};',
|
||||
'$mod.$rtti.$DynArray("TFloatRec.d$a", {',
|
||||
' eltype: rtl.char',
|
||||
'});',
|
||||
'$mod.$rtti.$Record("TFloatRec", {}).addFields("d", $mod.$rtti["TFloatRec.d$a"]);',
|
||||
'this.p = null;',
|
||||
'this.r = new $mod.TFloatRec();',
|
||||
@ -21898,19 +21906,19 @@ begin
|
||||
ConvertProgram;
|
||||
CheckSource('TestRTTI_LocalTypes',
|
||||
LinesToStr([ // statements
|
||||
'this.DoIt = function () {',
|
||||
' function TPoint(s) {',
|
||||
' if (s) {',
|
||||
' this.x = s.x;',
|
||||
' this.y = s.y;',
|
||||
' } else {',
|
||||
' this.x = 0;',
|
||||
' this.y = 0;',
|
||||
' };',
|
||||
' this.$equal = function (b) {',
|
||||
' return (this.x === b.x) && (this.y === b.y);',
|
||||
' };',
|
||||
'this.TPoint = function(s) {',
|
||||
' if (s) {',
|
||||
' this.x = s.x;',
|
||||
' this.y = s.y;',
|
||||
' } else {',
|
||||
' this.x = 0;',
|
||||
' this.y = 0;',
|
||||
' };',
|
||||
' this.$equal = function (b) {',
|
||||
' return (this.x === b.x) && (this.y === b.y);',
|
||||
' };',
|
||||
'};',
|
||||
'this.DoIt = function () {',
|
||||
'};',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
|
||||
Loading…
Reference in New Issue
Block a user