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

fcl-passrc: pasresolver: check proc type or proc var

Browse Source 
git-svn-id: trunk@35718 -
This commit is contained in:
Mattias Gaertner 2017-04-03 13:01:50 +00:00
parent 322720236c
commit 457d23a151
3 changed files with 388 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1366,7 +1366,7 @@ type
function IsDynOrOpenArray(TypeEl: TPasType): boolean;
function IsClassMethod(El: TPasElement): boolean;
function IsExternalClassName(aClass: TPasClassType; const ExtName: string): boolean;
function IsProcedureType(const ResolvedEl: TPasResolverResult): boolean;
function IsProcedureType(const ResolvedEl: TPasResolverResult; HasValue: boolean): boolean;
function IsArrayType(const ResolvedEl: TPasResolverResult): boolean;
function IsTypeCast(Params: TParamsExpr): boolean;
function ProcNeedsParams(El: TPasProcedureType): boolean;
@ -4429,7 +4429,7 @@ begin
CheckCanBeLHS(LeftResolved,true,El.left);
// compute RHS
Flags:=[rcSkipTypeAlias];
if IsProcedureType(LeftResolved) then
if IsProcedureType(LeftResolved,true) then
if (msDelphi in CurrentParser.CurrentModeswitches) then
Include(Flags,rcNoImplicitProc) // a proc type can use param less procs
else
@ -5094,7 +5094,7 @@ begin
// e.g. Name()() or Name[]()
ResolveExpr(SubParams,rraRead);
ComputeElement(SubParams,ResolvedEl,[rcNoImplicitProc]);
if IsProcedureType(ResolvedEl) and (rrfReadable in ResolvedEl.Flags) then
if IsProcedureType(ResolvedEl,true) then
begin
CheckCallProcCompatibility(TPasProcedureType(ResolvedEl.TypeEl),Params,true);
CreateReference(ResolvedEl.TypeEl,Value,Access);
@ -6767,7 +6767,7 @@ begin
{$ENDIF}
Flags:=[];
if IsProcedureType(ResultResolved) then
if IsProcedureType(ResultResolved,true) then
Include(Flags,rcNoImplicitProc);
ComputeElement(Param,ParamResolved,Flags);
{$IFDEF VerbosePasResolver}
@ -8905,7 +8905,7 @@ var
begin
ComputeElement(LHS,LeftResolved,[rcNoImplicitProc]);
Flags:=[];
IsProcType:=IsProcedureType(LeftResolved);
IsProcType:=IsProcedureType(LeftResolved,true);
if IsProcType then
if msDelphi in CurrentParser.CurrentModeswitches then
Include(Flags,rcNoImplicitProc)
@ -9072,7 +9072,7 @@ begin
begin
if LeftResolved.BaseType=btNil then
Flags:=[rcNoImplicitProcType]
else if IsProcedureType(LeftResolved) then
else if IsProcedureType(LeftResolved,true) then
Flags:=[rcNoImplicitProcType]
else
Flags:=[];
@ -9364,7 +9364,7 @@ begin
RHSFlags:=[];
if NeedVar then
Include(RHSFlags,rcNoImplicitProc)
else if IsProcedureType(ParamResolved) then
else if IsProcedureType(ParamResolved,true) then
Include(RHSFlags,rcNoImplicitProcType);
if (Expr is TParamsExpr) and (TParamsExpr(Expr).Kind=pekSet) then
@ -10087,7 +10087,7 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
end;
end;
end
else if IsProcedureType(ResolvedEl) then
else if IsProcedureType(ResolvedEl,true) then
begin
if [rcNoImplicitProc,rcNoImplicitProcType,rcConstant,rcType]*Flags=[] then
begin
@ -10294,7 +10294,7 @@ begin
Include(ResolvedEl.Flags,rrfReadable);
if GetPasPropertySetter(TPasProperty(El))<>nil then
Include(ResolvedEl.Flags,rrfWritable);
if IsProcedureType(ResolvedEl) then
if IsProcedureType(ResolvedEl,true) then
Include(ResolvedEl.Flags,rrfCanBeStatement);
end
else
@ -10317,7 +10317,7 @@ begin
ResolvedEl.Flags:=[rrfReadable];
if TPasArgument(El).Access in [argDefault, argVar, argOut] then
Include(ResolvedEl.Flags,rrfWritable);
if IsProcedureType(ResolvedEl) then
if IsProcedureType(ResolvedEl,true) then
Include(ResolvedEl.Flags,rrfCanBeStatement);
end
else if ElClass=TPasClassType then
@ -10621,10 +10621,14 @@ begin
end;
end;
function TPasResolver.IsProcedureType(const ResolvedEl: TPasResolverResult
): boolean;
function TPasResolver.IsProcedureType(const ResolvedEl: TPasResolverResult;
HasValue: boolean): boolean;
begin
Result:=(ResolvedEl.BaseType=btContext) and (ResolvedEl.TypeEl is TPasProcedureType);
if (ResolvedEl.BaseType<>btContext) or not (ResolvedEl.TypeEl is TPasProcedureType) then
exit(false);
if HasValue and not (rrfReadable in ResolvedEl.Flags) then
exit(false);
Result:=true;
end;
function TPasResolver.IsArrayType(const ResolvedEl: TPasResolverResult

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

@ -207,6 +207,7 @@ Works:
allow type casting to any array
- parameter, result type, assign from/to untyped
- operators equal, not equal
- callback: assign to jsvalue, equal, not equal
- ECMAScript6:
- use 0b for binary literals
- use 0o for octal literals
@ -664,7 +665,8 @@ type
// additional base types
function AddJSBaseType(const aName: string; Typ: TPas2jsBaseType): TResElDataPas2JSBaseType;
function IsJSBaseType(TypeEl: TPasType; Typ: TPas2jsBaseType): boolean;
function IsJSBaseType(const TypeResolved: TPasResolverResult; Typ: TPas2jsBaseType): boolean;
function IsJSBaseType(const TypeResolved: TPasResolverResult;
Typ: TPas2jsBaseType; HasValue: boolean = false): boolean;
function CheckAssignCompatibilityCustom(const LHS,
RHS: TPasResolverResult; ErrorEl: TPasElement;
RaiseOnIncompatible: boolean; var Handled: boolean): integer; override;
@ -1021,6 +1023,8 @@ type
Function ConvertRecordValues(El: TRecordValues; AContext: TConvertContext): TJSElement; virtual;
Function ConvertSelfExpression(El: TSelfExpr; AContext: TConvertContext): TJSElement; virtual;
Function ConvertBinaryExpression(El: TBinaryExpr; AContext: TConvertContext): TJSElement; virtual;
Function ConvertBinaryExpressionRes(El: TBinaryExpr; AContext: TConvertContext;
const LeftResolved, RightResolved: TPasResolverResult; var A,B: TJSElement): TJSElement; virtual;
Function ConvertSubIdentExpression(El: TBinaryExpr; AContext: TConvertContext): TJSElement; virtual;
Function ConvertBoolConstExpression(El: TBoolConstExpr; AContext: TConvertContext): TJSElement; virtual;
Function ConvertPrimitiveExpression(El: TPrimitiveExpr; AContext: TConvertContext): TJSElement; virtual;
@ -1849,9 +1853,13 @@ begin
end;
function TPas2JSResolver.IsJSBaseType(const TypeResolved: TPasResolverResult;
Typ: TPas2jsBaseType): boolean;
Typ: TPas2jsBaseType; HasValue: boolean): boolean;
begin
Result:=(TypeResolved.BaseType=btCustom) and IsJSBaseType(TypeResolved.TypeEl,Typ);
if (TypeResolved.BaseType<>btCustom) or not IsJSBaseType(TypeResolved.TypeEl,Typ) then
exit(false);
if HasValue and not (rrfReadable in TypeResolved.Flags) then
exit(false);
Result:=true;
end;
function TPas2JSResolver.CheckAssignCompatibilityCustom(const LHS,
@ -3113,14 +3121,10 @@ Var
C : TJSBinaryClass;
A,B: TJSElement;
UseBitwiseOp: Boolean;
DotExpr: TJSDotMemberExpression;
Call: TJSCallExpression;
LeftResolved, RightResolved: TPasResolverResult;
FunName: String;
Bracket: TJSBracketMemberExpression;
Flags: TPasResolverComputeFlags;
ModeSwitches: TModeSwitches;
NotEl: TJSUnaryNotExpression;
begin
Result:=Nil;
@ -3164,145 +3168,18 @@ begin
begin
if LeftResolved.BaseType=btNil then
Flags:=[rcNoImplicitProcType]
else if AContext.Resolver.IsProcedureType(LeftResolved) then
else if AContext.Resolver.IsProcedureType(LeftResolved,true) then
Flags:=[rcNoImplicitProcType]
else
Flags:=[];
end;
AContext.Resolver.ComputeElement(El.right,RightResolved,Flags);
Result:=ConvertBinaryExpressionRes(El,AContext,LeftResolved,RightResolved,A,B);
if Result<>nil then exit;
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.ConvertBinaryExpression Left=',GetResolverResultDesc(LeftResolved),' Right=',GetResolverResultDesc(RightResolved));
{$ENDIF}
if LeftResolved.BaseType=btSet then
begin
// set operators -> rtl.operatorfunction(a,b)
case El.OpCode of
eopAdd: FunName:=FBuiltInNames[pbifnSet_Union];
eopSubtract: FunName:=FBuiltInNames[pbifnSet_Difference];
eopMultiply: FunName:=FBuiltInNames[pbifnSet_Intersect];
eopSymmetricaldifference: FunName:=FBuiltInNames[pbifnSet_SymDiffSet];
eopEqual: FunName:=FBuiltInNames[pbifnSet_Equal];
eopNotEqual: FunName:=FBuiltInNames[pbifnSet_NotEqual];
eopGreaterThanEqual: FunName:=FBuiltInNames[pbifnSet_GreaterEqual];
eopLessthanEqual: FunName:=FBuiltInNames[pbifnSet_LowerEqual];
else
DoError(20170209151300,nBinaryOpcodeNotSupported,sBinaryOpcodeNotSupported,[OpcodeStrings[El.OpCode]],El);
end;
Call:=CreateCallExpression(El);
Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FunName]);
Call.Args.Elements.AddElement.Expr:=A;
Call.Args.Elements.AddElement.Expr:=B;
Result:=Call;
exit;
end
else if (RightResolved.BaseType=btSet) and (El.OpCode=eopIn) then
begin
// a in b -> b[a]
Bracket:=TJSBracketMemberExpression(CreateElement(TJSBracketMemberExpression,El));
Bracket.MExpr:=B;
Bracket.Name:=A;
Result:=Bracket;
exit;
end
else if (El.OpCode=eopIs) then
begin
// "A is B"
Call:=CreateCallExpression(El);
Result:=Call;
Call.Args.Elements.AddElement.Expr:=A; A:=nil;
if RightResolved.IdentEl is TPasClassOfType then
begin
// "A is class-of-type" -> "A is class"
FreeAndNil(B);
B:=CreateReferencePathExpr(TPasClassOfType(RightResolved.IdentEl).DestType,AContext);
end;
if (RightResolved.TypeEl is TPasClassType) and TPasClassType(RightResolved.TypeEl).IsExternal then
begin
// B is an external class -> "rtl.isExt(A,B)"
Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FBuiltInNames[pbifnIsExt]]);
Call.Args.Elements.AddElement.Expr:=B; B:=nil;
end
else if LeftResolved.TypeEl is TPasClassOfType then
begin
// A is a TPasClassOfType -> "rtl.is(A,B)"
Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FBuiltInNames[pbifnIs]]);
Call.Args.Elements.AddElement.Expr:=B; B:=nil;
end
else
begin
// use directly "B.isPrototypeOf(A)"
DotExpr:=TJSDotMemberExpression(CreateElement(TJSDotMemberExpression,El));
DotExpr.MExpr:=B; B:=nil;
DotExpr.Name:='isPrototypeOf';
Call.Expr:=DotExpr;
end;
exit;
end
else if (El.OpCode in [eopEqual,eopNotEqual]) then
begin
if AContext.Resolver.IsProcedureType(LeftResolved) then
begin
if RightResolved.BaseType=btNil then
else if AContext.Resolver.IsProcedureType(RightResolved) then
begin
// convert "proctypeA = proctypeB" to "rtl.eqCallback(proctypeA,proctypeB)"
Call:=CreateCallExpression(El);
Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FBuiltInNames[pbifnProcType_Equal]]);
Call.Args.Elements.AddElement.Expr:=A;
Call.Args.Elements.AddElement.Expr:=B;
if El.OpCode=eopNotEqual then
begin
// convert "proctypeA <> proctypeB" to "!rtl.eqCallback(proctypeA,proctypeB)"
NotEl:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,El));
NotEl.A:=Call;
Result:=NotEl;
end
else
Result:=Call;
exit;
end;
end
else if LeftResolved.TypeEl is TPasRecordType then
begin
// convert "recordA = recordB" to "recordA.$equal(recordB)"
Call:=CreateCallExpression(El);
Call.Expr:=CreateDotExpression(El,A,CreateBuiltInIdentifierExpr(FBuiltInNames[pbifnRecordEqual]));
Call.Args.Elements.AddElement.Expr:=B;
if El.OpCode=eopNotEqual then
begin
// convert "recordA = recordB" to "!recordA.$equal(recordB)"
NotEl:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,El));
NotEl.A:=Call;
Result:=NotEl;
end
else
Result:=Call;
exit;
end
else if LeftResolved.TypeEl is TPasArrayType then
begin
if RightResolved.BaseType=btNil then
begin
// convert "array = nil" to "rtl.length(array) > 0"
FreeAndNil(B);
Result:=CreateCmpArrayWithNil(El,A,El.OpCode);
A:=nil;
exit;
end;
end
else if RightResolved.TypeEl is TPasArrayType then
begin
if LeftResolved.BaseType=btNil then
begin
// convert "nil = array" to "0 < rtl.length(array)"
FreeAndNil(A);
Result:=CreateCmpArrayWithNil(El,B,El.OpCode);
B:=nil;
exit;
end;
end;
end;
end;
C:=BinClasses[El.OpCode];
@ -3376,6 +3253,172 @@ begin
end;
end;
function TPasToJSConverter.ConvertBinaryExpressionRes(El: TBinaryExpr;
AContext: TConvertContext; const LeftResolved,
RightResolved: TPasResolverResult; var A, B: TJSElement): TJSElement;
function CreateEqualCallback: TJSElement;
var
Call: TJSCallExpression;
NotEl: TJSUnaryNotExpression;
begin
// convert "proctypeA = proctypeB" to "rtl.eqCallback(proctypeA,proctypeB)"
Call:=CreateCallExpression(El);
Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FBuiltInNames[pbifnProcType_Equal]]);
Call.Args.Elements.AddElement.Expr:=A;
A:=nil;
Call.Args.Elements.AddElement.Expr:=B;
B:=nil;
if El.OpCode=eopNotEqual then
begin
// convert "proctypeA <> proctypeB" to "!rtl.eqCallback(proctypeA,proctypeB)"
NotEl:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,El));
NotEl.A:=Call;
Result:=NotEl;
end
else
Result:=Call;
end;
var
FunName: String;
Call: TJSCallExpression;
Bracket: TJSBracketMemberExpression;
DotExpr: TJSDotMemberExpression;
NotEl: TJSUnaryNotExpression;
begin
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.ConvertBinaryExpressionRes OpCode="',OpcodeStrings[El.OpCode],'" Left=',GetResolverResultDesc(LeftResolved),' Right=',GetResolverResultDesc(RightResolved));
{$ENDIF}
Result:=nil;
if LeftResolved.BaseType=btSet then
begin
// set operators -> rtl.operatorfunction(a,b)
case El.OpCode of
eopAdd: FunName:=FBuiltInNames[pbifnSet_Union];
eopSubtract: FunName:=FBuiltInNames[pbifnSet_Difference];
eopMultiply: FunName:=FBuiltInNames[pbifnSet_Intersect];
eopSymmetricaldifference: FunName:=FBuiltInNames[pbifnSet_SymDiffSet];
eopEqual: FunName:=FBuiltInNames[pbifnSet_Equal];
eopNotEqual: FunName:=FBuiltInNames[pbifnSet_NotEqual];
eopGreaterThanEqual: FunName:=FBuiltInNames[pbifnSet_GreaterEqual];
eopLessthanEqual: FunName:=FBuiltInNames[pbifnSet_LowerEqual];
else
DoError(20170209151300,nBinaryOpcodeNotSupported,sBinaryOpcodeNotSupported,[OpcodeStrings[El.OpCode]],El);
end;
Call:=CreateCallExpression(El);
Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FunName]);
Call.Args.Elements.AddElement.Expr:=A;
A:=nil;
Call.Args.Elements.AddElement.Expr:=B;
B:=nil;
Result:=Call;
exit;
end
else if (RightResolved.BaseType=btSet) and (El.OpCode=eopIn) then
begin
// a in b -> b[a]
Bracket:=TJSBracketMemberExpression(CreateElement(TJSBracketMemberExpression,El));
Bracket.MExpr:=B;
B:=nil;
Bracket.Name:=A;
A:=nil;
Result:=Bracket;
exit;
end
else if (El.OpCode=eopIs) then
begin
// "A is B"
Call:=CreateCallExpression(El);
Result:=Call;
Call.Args.Elements.AddElement.Expr:=A; A:=nil;
if RightResolved.IdentEl is TPasClassOfType then
begin
// "A is class-of-type" -> "A is class"
FreeAndNil(B);
B:=CreateReferencePathExpr(TPasClassOfType(RightResolved.IdentEl).DestType,AContext);
end;
if (RightResolved.TypeEl is TPasClassType) and TPasClassType(RightResolved.TypeEl).IsExternal then
begin
// B is an external class -> "rtl.isExt(A,B)"
Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FBuiltInNames[pbifnIsExt]]);
Call.Args.Elements.AddElement.Expr:=B; B:=nil;
end
else if LeftResolved.TypeEl is TPasClassOfType then
begin
// A is a TPasClassOfType -> "rtl.is(A,B)"
Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FBuiltInNames[pbifnIs]]);
Call.Args.Elements.AddElement.Expr:=B; B:=nil;
end
else
begin
// use directly "B.isPrototypeOf(A)"
DotExpr:=TJSDotMemberExpression(CreateElement(TJSDotMemberExpression,El));
DotExpr.MExpr:=B; B:=nil;
DotExpr.Name:='isPrototypeOf';
Call.Expr:=DotExpr;
end;
exit;
end
else if (El.OpCode in [eopEqual,eopNotEqual]) then
begin
if AContext.Resolver.IsProcedureType(LeftResolved,true) then
begin
if RightResolved.BaseType=btNil then
else if AContext.Resolver.IsProcedureType(RightResolved,true)
or AContext.Resolver.IsJSBaseType(RightResolved,pbtJSValue,true) then
exit(CreateEqualCallback);
end
else if AContext.Resolver.IsProcedureType(RightResolved,true) then
begin
if LeftResolved.BaseType=btNil then
else if AContext.Resolver.IsJSBaseType(LeftResolved,pbtJSValue,true) then
exit(CreateEqualCallback);
end
else if LeftResolved.TypeEl is TPasRecordType then
begin
// convert "recordA = recordB" to "recordA.$equal(recordB)"
Call:=CreateCallExpression(El);
Call.Expr:=CreateDotExpression(El,A,CreateBuiltInIdentifierExpr(FBuiltInNames[pbifnRecordEqual]));
A:=nil;
Call.Args.Elements.AddElement.Expr:=B;
B:=nil;
if El.OpCode=eopNotEqual then
begin
// convert "recordA = recordB" to "!recordA.$equal(recordB)"
NotEl:=TJSUnaryNotExpression(CreateElement(TJSUnaryNotExpression,El));
NotEl.A:=Call;
Result:=NotEl;
end
else
Result:=Call;
exit;
end
else if LeftResolved.TypeEl is TPasArrayType then
begin
if RightResolved.BaseType=btNil then
begin
// convert "array = nil" to "rtl.length(array) > 0"
FreeAndNil(B);
Result:=CreateCmpArrayWithNil(El,A,El.OpCode);
A:=nil;
exit;
end;
end
else if RightResolved.TypeEl is TPasArrayType then
begin
if LeftResolved.BaseType=btNil then
begin
// convert "nil = array" to "0 < rtl.length(array)"
FreeAndNil(A);
Result:=CreateCmpArrayWithNil(El,B,El.OpCode);
B:=nil;
exit;
end;
end;
end;
end;
function TPasToJSConverter.ConvertSubIdentExpression(El: TBinaryExpr;
AContext: TConvertContext): TJSElement;
// connect El.left and El.right with a dot.
@ -7300,17 +7343,37 @@ begin
begin
// chomp dot member -> rtl.createCallback(scope,"FunName")
DotExpr:=TJSDotMemberExpression(Scope);
Scope:=DotExpr.MExpr;
DotExpr.MExpr:=nil;
FunName:=String(DotExpr.Name);
if not IsValidJSIdentifier(DotExpr.Name) then
DotPos:=PosLast('.',FunName);
if DotPos>0 then
begin
// e.g. path dot $class.funname
// keep DotExpr, chomp funname
DotExpr.Name:=TJSString(LeftStr(FunName,DotPos-1));
FunName:=copy(FunName,DotPos+1);
if not IsValidJSIdentifier(DotExpr.Name) then
begin
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateCallback ',GetObjName(Scope),' DotExpr.Name="',DotExpr.Name,'"');
{$ENDIF}
DoError(20170215161802,nInvalidFunctionReference,sInvalidFunctionReference,[],El);
end;
end
else
begin
// e.g. path dot funname
// delete DotExpr
Scope:=DotExpr.MExpr;
DotExpr.MExpr:=nil;
FreeAndNil(DotExpr);
end;
if not IsValidJSIdentifier(TJSString(FunName)) then
begin
{$IFDEF VerbosePas2JS}
writeln('TPasToJSConverter.CreateCallback ',GetObjName(Scope),' Name="',FunName,'"');
writeln('TPasToJSConverter.CreateCallback ',GetObjName(Scope),' FunName="',FunName,'"');
{$ENDIF}
DoError(20170215161802,nInvalidFunctionReference,sInvalidFunctionReference,[],El);
end;
FreeAndNil(DotExpr);
Call.Args.Elements.AddElement.Expr:=Scope;
// add function name as parameter
Call.Args.Elements.AddElement.Expr:=CreateLiteralString(El,FunName);
@ -7535,7 +7598,7 @@ begin
begin
AContext.Resolver.ComputeElement(El.left,AssignContext.LeftResolved,[rcNoImplicitProc]);
Flags:=[];
LeftIsProcType:=AContext.Resolver.IsProcedureType(AssignContext.LeftResolved);
LeftIsProcType:=AContext.Resolver.IsProcedureType(AssignContext.LeftResolved,true);
if LeftIsProcType then
begin
if msDelphi in AContext.CurrentModeswitches then
@ -8743,7 +8806,7 @@ begin
ExprFlags:=[];
if NeedVar then
Include(ExprFlags,rcNoImplicitProc)
else if AContext.Resolver.IsProcedureType(ArgResolved) then
else if AContext.Resolver.IsProcedureType(ArgResolved,true) then
Include(ExprFlags,rcNoImplicitProcType);
if (ArgResolved.TypeEl is TPasArrayType)

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

@ -253,7 +253,7 @@ type
Procedure TestForLoop_Nested;
Procedure TestRepeatUntil;
Procedure TestAsmBlock;
Procedure TestAsmPas_Impl;
Procedure TestAsmPas_Impl; // ToDo
Procedure TestTryFinally;
Procedure TestTryExcept;
Procedure TestCaseOf;
@ -371,7 +371,7 @@ type
Procedure TestExternalClass_CallClassFunctionOfInstanceFail;
Procedure TestExternalClass_BracketOperatorOld;
Procedure TestExternalClass_BracketOperator;
// ToDo: check default property accessors have one parameter
// ToDo: check array accessors has one parameter
// proc types
Procedure TestProcType;
@ -395,7 +395,9 @@ type
Procedure TestJSValue_ArrayOfJSValue;
Procedure TestJSValue_Params;
Procedure TestJSValue_UntypedParam;
Procedure TestJSValue_FuncType;
Procedure TestJSValue_FuncResultType;
Procedure TestJSValue_ProcType_Assign;
Procedure TestJSValue_ProcType_Equal;
end;
function LinesToStr(Args: array of const): string;
@ -10009,7 +10011,7 @@ begin
'']));
end;
procedure TTestModule.TestJSValue_FuncType;
procedure TTestModule.TestJSValue_FuncResultType;
begin
StartProgram(false);
Add('type');
@ -10048,6 +10050,164 @@ begin
'']));
end;
procedure TTestModule.TestJSValue_ProcType_Assign;
begin
StartProgram(false);
Add('type');
Add(' integer = longint;');
Add(' TObject = class');
Add(' class function GetGlob: integer;');
Add(' function Getter: integer;');
Add(' end;');
Add('class function TObject.GetGlob: integer;');
Add('var v1: jsvalue;');
Add('begin');
Add(' v1:=@GetGlob;');
Add(' v1:=@Self.GetGlob;');
Add('end;');
Add('function TObject.Getter: integer;');
Add('var v2: jsvalue;');
Add('begin');
Add(' v2:=@Getter;');
Add(' v2:=@Self.Getter;');
Add(' v2:=@GetGlob;');
Add(' v2:=@Self.GetGlob;');
Add('end;');
Add('function GetIt(i: integer): integer;');
Add('var v3: jsvalue;');
Add('begin');
Add(' v3:=@GetIt;');
Add('end;');
Add('var');
Add(' V: JSValue;');
Add(' o: TObject;');
Add('begin');
Add(' v:=@GetIt;');
Add(' v:=@o.Getter;');
Add(' v:=@o.GetGlob;');
ConvertProgram;
CheckSource('TestJSValue_ProcType_Assign',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.GetGlob = function () {',
' var Result = 0;',
' var v1 = undefined;',
' v1 = rtl.createCallback(this, "GetGlob");',
' v1 = rtl.createCallback(this, "GetGlob");',
' return Result;',
' };',
' this.Getter = function () {',
' var Result = 0;',
' var v2 = undefined;',
' v2 = rtl.createCallback(this, "Getter");',
' v2 = rtl.createCallback(this, "Getter");',
' v2 = rtl.createCallback(this.$class, "GetGlob");',
' v2 = rtl.createCallback(this.$class, "GetGlob");',
' return Result;',
' };',
'});',
'this.GetIt = function (i) {',
' var Result = 0;',
' var v3 = undefined;',
' v3 = rtl.createCallback(this, "GetIt");',
' return Result;',
'};',
'this.V = undefined;',
'this.o = null;',
'']),
LinesToStr([ // this.$main
'this.V = rtl.createCallback(this, "GetIt");',
'this.V = rtl.createCallback(this.o, "Getter");',
'this.V = rtl.createCallback(this.o.$class, "GetGlob");',
'']));
end;
procedure TTestModule.TestJSValue_ProcType_Equal;
begin
StartProgram(false);
Add('type');
Add(' integer = longint;');
Add(' TObject = class');
Add(' class function GetGlob: integer;');
Add(' function Getter: integer;');
Add(' end;');
Add('class function TObject.GetGlob: integer;');
Add('var v1: jsvalue;');
Add('begin');
Add(' if v1=@GetGlob then;');
Add(' if v1=@Self.GetGlob then ;');
Add('end;');
Add('function TObject.Getter: integer;');
Add('var v2: jsvalue;');
Add('begin');
Add(' if v2=@Getter then;');
Add(' if v2=@Self.Getter then ;');
Add(' if v2=@GetGlob then;');
Add(' if v2=@Self.GetGlob then;');
Add('end;');
Add('function GetIt(i: integer): integer;');
Add('var v3: jsvalue;');
Add('begin');
Add(' if v3=@GetIt then;');
Add('end;');
Add('var');
Add(' V: JSValue;');
Add(' o: TObject;');
Add('begin');
Add(' if v=@GetIt then;');
Add(' if v=@o.Getter then;');
Add(' if v=@o.GetGlob then;');
Add(' if @GetIt=v then;');
Add(' if @o.Getter=v then;');
Add(' if @o.GetGlob=v then;');
ConvertProgram;
CheckSource('TestJSValue_ProcType_Equal',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' };',
' this.$final = function () {',
' };',
' this.GetGlob = function () {',
' var Result = 0;',
' var v1 = undefined;',
' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
' if (rtl.eqCallback(v1, rtl.createCallback(this, "GetGlob"))) ;',
' return Result;',
' };',
' this.Getter = function () {',
' var Result = 0;',
' var v2 = undefined;',
' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
' if (rtl.eqCallback(v2, rtl.createCallback(this, "Getter"))) ;',
' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
' if (rtl.eqCallback(v2, rtl.createCallback(this.$class, "GetGlob"))) ;',
' return Result;',
' };',
'});',
'this.GetIt = function (i) {',
' var Result = 0;',
' var v3 = undefined;',
' if (rtl.eqCallback(v3, rtl.createCallback(this, "GetIt"))) ;',
' return Result;',
'};',
'this.V = undefined;',
'this.o = null;',
'']),
LinesToStr([ // this.$main
'if (rtl.eqCallback(this.V, rtl.createCallback(this, "GetIt"))) ;',
'if (rtl.eqCallback(this.V, rtl.createCallback(this.o, "Getter"))) ;',
'if (rtl.eqCallback(this.V, rtl.createCallback(this.o.$class, "GetGlob"))) ;',
'if (rtl.eqCallback(rtl.createCallback(this, "GetIt"), this.V)) ;',
'if (rtl.eqCallback(rtl.createCallback(this.o, "Getter"), this.V)) ;',
'if (rtl.eqCallback(rtl.createCallback(this.o.$class, "GetGlob"), this.V)) ;',
'']));
end;
Initialization
RegisterTests([TTestModule]);
end.