mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-12-16 02:30:41 +01:00
pastojs: forbid pascalclass.new
git-svn-id: trunk@38977 -
This commit is contained in:
Mattias Gaertner
parent
5f8f00dcd3
commit
e523672c12
@ -468,6 +468,7 @@ const
|
||||
nFreeNeedsVar = 4023;
|
||||
nDuplicateGUIDXInYZ = 4024;
|
||||
nCantCallExtBracketAccessor = 4025;
|
||||
nJSNewNotSupported = 4026;
|
||||
// resourcestring patterns of messages
|
||||
resourcestring
|
||||
sPasElementNotSupported = 'Pascal element not supported: %s';
|
||||
@ -495,6 +496,7 @@ resourcestring
|
||||
sFreeNeedsVar = 'Free needs a variable';
|
||||
sDuplicateGUIDXInYZ = 'Duplicate GUID %s in %s and %s';
|
||||
sCantCallExtBracketAccessor = 'cannot call external bracket accessor, use a property instead';
|
||||
sJSNewNotSupported = 'Pascal class does not support the "new" constructor';
|
||||
|
||||
const
|
||||
ExtClassBracketAccessor = '[]'; // external name '[]' marks the array param getter/setter
|
||||
@ -1142,6 +1144,8 @@ type
|
||||
procedure ResolveImplAsm(El: TPasImplAsmStatement); override;
|
||||
procedure ResolveNameExpr(El: TPasExpr; const aName: string;
|
||||
Access: TResolvedRefAccess); override;
|
||||
procedure ResolveFuncParamsExpr(Params: TParamsExpr;
|
||||
Access: TResolvedRefAccess); override;
|
||||
procedure FinishInterfaceSection(Section: TPasSection); override;
|
||||
procedure FinishTypeSection(El: TPasDeclarations); override;
|
||||
procedure FinishModule(CurModule: TPasModule); override;
|
||||
@ -1155,6 +1159,7 @@ type
|
||||
procedure FinishArgument(El: TPasArgument); override;
|
||||
procedure FinishProcedureType(El: TPasProcedureType); override;
|
||||
procedure FinishPropertyOfClass(PropEl: TPasProperty); override;
|
||||
procedure CheckExternalClassConstructor(Ref: TResolvedReference); virtual;
|
||||
procedure CheckConditionExpr(El: TPasExpr;
|
||||
const ResolvedEl: TPasResolverResult); override;
|
||||
procedure CheckNewInstanceFunction(ClassScope: TPas2JSClassScope); virtual;
|
||||
@ -1226,6 +1231,7 @@ type
|
||||
function HasTypeInfo(El: TPasType): boolean; override;
|
||||
function IsTObjectFreeMethod(El: TPasExpr): boolean; virtual;
|
||||
function IsExternalBracketAccessor(El: TPasElement): boolean;
|
||||
Function IsExternalClassConstructor(El: TPasElement): boolean;
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
@ -1474,7 +1480,6 @@ type
|
||||
Function GetExpressionValueType(El: TPasExpr; AContext: TConvertContext ): TJSType; virtual;
|
||||
Function GetPasIdentValueType(AName: String; AContext: TConvertContext): TJSType; virtual;
|
||||
Function ComputeConstString(Expr: TPasExpr; AContext: TConvertContext; NotEmpty: boolean): String; virtual;
|
||||
Function IsExternalClassConstructor(El: TPasElement): boolean;
|
||||
Function IsLiteralInteger(El: TJSElement; out Number: MaxPrecInt): boolean;
|
||||
// Name mangling
|
||||
Function GetOverloadName(El: TPasElement; AContext: TConvertContext): string;
|
||||
@ -2490,7 +2495,25 @@ begin
|
||||
if (CompareText(aName,'free')=0) then
|
||||
CheckTObjectFree(Ref)
|
||||
else if (Ref.Declaration is TPasResultElement) then
|
||||
CheckResultEl(Ref);
|
||||
CheckResultEl(Ref)
|
||||
else if IsExternalClassConstructor(Ref.Declaration) then
|
||||
CheckExternalClassConstructor(Ref);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPas2JSResolver.ResolveFuncParamsExpr(Params: TParamsExpr;
|
||||
Access: TResolvedRefAccess);
|
||||
var
|
||||
Value: TPasExpr;
|
||||
Ref: TResolvedReference;
|
||||
begin
|
||||
inherited ResolveFuncParamsExpr(Params, Access);
|
||||
Value:=Params.Value;
|
||||
if Value.CustomData is TResolvedReference then
|
||||
begin
|
||||
Ref:=TResolvedReference(Value.CustomData);
|
||||
if IsExternalClassConstructor(Ref.Declaration) then
|
||||
CheckExternalClassConstructor(Ref);
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -3174,6 +3197,32 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPas2JSResolver.CheckExternalClassConstructor(Ref: TResolvedReference
|
||||
);
|
||||
var
|
||||
TypeEl: TPasType;
|
||||
begin
|
||||
if not (Ref.Context is TResolvedRefCtxConstructor) then
|
||||
RaiseMsg(20180511165144,nJSNewNotSupported,sJSNewNotSupported,[],Ref.Element);
|
||||
TypeEl:=TResolvedRefCtxConstructor(Ref.Context).Typ;
|
||||
if TypeEl.ClassType=TPasClassType then
|
||||
begin
|
||||
// ClassType.new
|
||||
if not TPasClassType(TypeEl).IsExternal then
|
||||
RaiseMsg(20180511165316,nJSNewNotSupported,sJSNewNotSupported,[],Ref.Element);
|
||||
end
|
||||
else if TypeEl.ClassType=TPasClassOfType then
|
||||
begin
|
||||
TypeEl:=ResolveAliasType(TPasClassOfType(TypeEl).DestType);
|
||||
if TypeEl.ClassType=TPasClassType then
|
||||
begin
|
||||
// ClassOfVar.new
|
||||
if not TPasClassType(TypeEl).IsExternal then
|
||||
RaiseMsg(20180511175309,nJSNewNotSupported,sJSNewNotSupported,[],Ref.Element);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPas2JSResolver.CheckConditionExpr(El: TPasExpr;
|
||||
const ResolvedEl: TPasResolverResult);
|
||||
begin
|
||||
@ -4377,6 +4426,20 @@ begin
|
||||
Result:=ExtName=ExtClassBracketAccessor;
|
||||
end;
|
||||
|
||||
function TPas2JSResolver.IsExternalClassConstructor(El: TPasElement): boolean;
|
||||
var
|
||||
P: TPasElement;
|
||||
begin
|
||||
if (El.ClassType=TPasConstructor)
|
||||
and (pmExternal in TPasConstructor(El).Modifiers) then
|
||||
begin
|
||||
P:=El.Parent;
|
||||
if (P<>nil) and (P.ClassType=TPasClassType) and TPasClassType(P).IsExternal then
|
||||
exit(true);
|
||||
end;
|
||||
Result:=false;
|
||||
end;
|
||||
|
||||
{ TParamContext }
|
||||
|
||||
constructor TParamContext.Create(PasEl: TPasElement; JSEl: TJSElement;
|
||||
@ -5286,20 +5349,6 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPasToJSConverter.IsExternalClassConstructor(El: TPasElement): boolean;
|
||||
var
|
||||
P: TPasElement;
|
||||
begin
|
||||
if (El.ClassType=TPasConstructor)
|
||||
and (pmExternal in TPasConstructor(El).Modifiers) then
|
||||
begin
|
||||
P:=El.Parent;
|
||||
if (P<>nil) and (P.ClassType=TPasClassType) and TPasClassType(P).IsExternal then
|
||||
exit(true);
|
||||
end;
|
||||
Result:=false;
|
||||
end;
|
||||
|
||||
function TPasToJSConverter.IsLiteralInteger(El: TJSElement; out
|
||||
Number: MaxPrecInt): boolean;
|
||||
begin
|
||||
@ -6119,7 +6168,7 @@ begin
|
||||
begin
|
||||
RightRef:=TResolvedReference(RightEl.CustomData);
|
||||
RightRefDecl:=RightRef.Declaration;
|
||||
if IsExternalClassConstructor(RightRefDecl) then
|
||||
if aResolver.IsExternalClassConstructor(RightRefDecl) then
|
||||
begin
|
||||
if ParamsExpr<>nil then
|
||||
begin
|
||||
@ -6127,6 +6176,7 @@ begin
|
||||
Result:=ConvertParamsExpression(El.right as TParamsExpr,AContext);
|
||||
end
|
||||
else
|
||||
// e.g. ExtClass.new;
|
||||
Result:=ConvertExternalConstructor(El.left,RightRef,nil,AContext);
|
||||
exit;
|
||||
end
|
||||
@ -6398,7 +6448,7 @@ begin
|
||||
Ref:=TResolvedReference(El.CustomData);
|
||||
Decl:=Ref.Declaration;
|
||||
|
||||
if IsExternalClassConstructor(Decl) then
|
||||
if aResolver.IsExternalClassConstructor(Decl) then
|
||||
begin
|
||||
// create external object/function
|
||||
Result:=ConvertExternalConstructor(nil,Ref,nil,AContext);
|
||||
@ -7650,10 +7700,10 @@ begin
|
||||
else
|
||||
RaiseNotSupported(El,AContext,20170325160624);
|
||||
end
|
||||
else if IsExternalClassConstructor(Decl) then
|
||||
else if aResolver.IsExternalClassConstructor(Decl) then
|
||||
begin
|
||||
// create external object/function
|
||||
// -> check if there is complex left side, e.g. TExtA.Create(params)
|
||||
// -> check if there is complex left side, e.g. TExtA.new(params)
|
||||
Left:=El;
|
||||
while (Left.Parent.ClassType=TParamsExpr) do
|
||||
Left:=Left.Parent;
|
||||
@ -7983,6 +8033,8 @@ begin
|
||||
else
|
||||
// use external class name
|
||||
ExtName:=(Proc.Parent as TPasClassType).ExternalName;
|
||||
if ExtName='' then
|
||||
DoError(20180511163944,nJSNewNotSupported,sJSNewNotSupported,[],ParamsExpr);
|
||||
ExtNameEl:=CreatePrimitiveDotExpr(ExtName,Ref.Element);
|
||||
end;
|
||||
|
||||
|
||||
@ -467,6 +467,8 @@ type
|
||||
Procedure TestExternalClass_New;
|
||||
Procedure TestExternalClass_ClassOf_New;
|
||||
Procedure TestExternalClass_FuncClassOf_New;
|
||||
Procedure TestExternalClass_New_PasClassFail;
|
||||
Procedure TestExternalClass_New_PasClassBracketsFail;
|
||||
Procedure TestExternalClass_LocalConstSameName;
|
||||
Procedure TestExternalClass_ReintroduceOverload;
|
||||
Procedure TestExternalClass_Inherited;
|
||||
@ -12467,27 +12469,28 @@ end;
|
||||
procedure TTestModule.TestExternalClass_FuncClassOf_New;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('{$modeswitch externalclass}');
|
||||
Add('type');
|
||||
Add(' TExtAClass = class of TExtA;');
|
||||
Add(' TExtA = class external name ''ExtA''');
|
||||
Add(' constructor New;');
|
||||
Add(' end;');
|
||||
Add('function GetCreator: TExtAClass;');
|
||||
Add('begin');
|
||||
Add(' Result:=TExtA;');
|
||||
Add('end;');
|
||||
Add('var');
|
||||
Add(' A: texta;');
|
||||
Add('begin');
|
||||
Add(' a:=getcreator.new;');
|
||||
Add(' a:=getcreator().new;');
|
||||
Add(' a:=getcreator().new();');
|
||||
Add(' a:=getcreator.new();');
|
||||
Add(' with getcreator do begin');
|
||||
Add(' a:=new;');
|
||||
Add(' a:=new();');
|
||||
Add(' end;');
|
||||
Add([
|
||||
'{$modeswitch externalclass}',
|
||||
'type',
|
||||
' TExtAClass = class of TExtA;',
|
||||
' TExtA = class external name ''ExtA''',
|
||||
' constructor New;',
|
||||
' end;',
|
||||
'function GetCreator: TExtAClass;',
|
||||
'begin',
|
||||
' Result:=TExtA;',
|
||||
'end;',
|
||||
'var',
|
||||
' A: texta;',
|
||||
'begin',
|
||||
' a:=getcreator.new;',
|
||||
' a:=getcreator().new;',
|
||||
' a:=getcreator().new();',
|
||||
' a:=getcreator.new();',
|
||||
' with getcreator do begin',
|
||||
' a:=new;',
|
||||
' a:=new();',
|
||||
' end;']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestExternalClass_FuncClassOf_New',
|
||||
LinesToStr([ // statements
|
||||
@ -12509,6 +12512,42 @@ begin
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestExternalClass_New_PasClassFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$modeswitch externalclass}',
|
||||
'type',
|
||||
' TExtA = class external name ''ExtA''',
|
||||
' constructor New;',
|
||||
' end;',
|
||||
' TBird = class(TExtA)',
|
||||
' end;',
|
||||
'begin',
|
||||
' TBird.new;',
|
||||
'']);
|
||||
SetExpectedPasResolverError(sJSNewNotSupported,nJSNewNotSupported);
|
||||
ConvertProgram;
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestExternalClass_New_PasClassBracketsFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$modeswitch externalclass}',
|
||||
'type',
|
||||
' TExtA = class external name ''ExtA''',
|
||||
' constructor New;',
|
||||
' end;',
|
||||
' TBird = class(TExtA)',
|
||||
' end;',
|
||||
'begin',
|
||||
' TBird.new();',
|
||||
'']);
|
||||
SetExpectedPasResolverError(sJSNewNotSupported,nJSNewNotSupported);
|
||||
ConvertProgram;
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestExternalClass_LocalConstSameName;
|
||||
begin
|
||||
StartProgram(false);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user