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

pastojs: specialzie anonymous function

Browse Source 
git-svn-id: trunk@49093 -
This commit is contained in:
Mattias Gaertner 2021-03-31 20:50:37 +00:00
parent 07a8e6c1d6
commit b5a8164233
3 changed files with 72 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -17947,7 +17947,7 @@ begin
if GenEl.Body<>nil then if GenEl.Body<>nil then
begin begin
// implementation proc // implementation or anonymous proc
if SpecializedItem<>nil then if SpecializedItem<>nil then
SpecializedItem.Step:=prssImplementationBuilding; SpecializedItem.Step:=prssImplementationBuilding;
GenBody:=GenEl.Body; GenBody:=GenEl.Body;
@ -18435,11 +18435,21 @@ begin
end; end;
procedure TPasResolver.SpecializeProcedureExpr(GenEl, SpecEl: TProcedureExpr); procedure TPasResolver.SpecializeProcedureExpr(GenEl, SpecEl: TProcedureExpr);
var
GenProc: TPasAnonymousProcedure;
NewClass: TPTreeElement;
begin begin
SpecializeExpr(GenEl,SpecEl); SpecializeExpr(GenEl,SpecEl);
if GenEl.Proc=nil then GenProc:=GenEl.Proc;
if GenProc=nil then
RaiseNotYetImplemented(20190808221018,GenEl); RaiseNotYetImplemented(20190808221018,GenEl);
RaiseNotYetImplemented(20190808221040,GenEl); if not (GenProc is TPasAnonymousProcedure) then
RaiseNotYetImplemented(20210331224052,GenEl);
if GenProc.Parent<>GenEl then
RaiseNotYetImplemented(20210331223856,GenEl);
NewClass:=TPTreeElement(GenProc.ClassType);
SpecEl.Proc:=TPasAnonymousProcedure(NewClass.Create(GenProc.Name,SpecEl));
SpecializeElement(GenProc,SpecEl.Proc);
end; end;
procedure TPasResolver.SpecializeResString(GenEl, SpecEl: TPasResString); procedure TPasResolver.SpecializeResString(GenEl, SpecEl: TPasResString);

59
packages/pastojs/tests/tcgenerics.pas
View File

@ -75,6 +75,7 @@ type
procedure TestGenProc_TypeInfo; procedure TestGenProc_TypeInfo;
procedure TestGenProc_Infer_Widen; procedure TestGenProc_Infer_Widen;
procedure TestGenProc_Infer_PassAsArg; procedure TestGenProc_Infer_PassAsArg;
procedure TestGenProc_AnonymousProc;
// ToDo: FuncName:= instead of Result:= // ToDo: FuncName:= instead of Result:=
// generic methods // generic methods
@ -2216,6 +2217,64 @@ begin
''])); '']));
end; end;
procedure TTestGenerics.TestGenProc_AnonymousProc;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TProc = reference to procedure;',
' TFunc = reference to function(Value: JSValue): JSValue;',
'function Run<T>(a: T; p: TProc): T;',
'var b: T;',
' f: TFunc;',
'begin',
' Result:=Run(a,procedure()begin end);',
' f:=function(b: JSValue): JSValue begin end;',
' f:=function(b: JSValue): JSValue',
' function Sub(c: JSValue): JSValue;',
' begin',
' Result:=c;',
' end;',
' begin',
' Result:=Sub(b);',
' end;',
'end;',
'begin',
' Run<word>(3,procedure() begin end);',
'']);
ConvertProgram;
CheckSource('TestGenProc_AnonymousProc',
LinesToStr([ // statements
'this.Run$G1 = function (a, p) {',
' var Result = 0;',
' var b = 0;',
' var f = null;',
' Result = $mod.Run$G1(a, function () {',
' });',
' f = function (b) {',
' var Result = undefined;',
' return Result;',
' };',
' f = function (b) {',
' var Result = undefined;',
' function Sub(c) {',
' var Result = undefined;',
' Result = c;',
' return Result;',
' };',
' Result = Sub(b);',
' return Result;',
' };',
' return Result;',
'};',
'']),
LinesToStr([ // $mod.$main
'$mod.Run$G1(3, function () {',
'});',
'']));
end;
procedure TTestGenerics.TestGenMethod_ImplicitSpec_ObjFPC; procedure TTestGenerics.TestGenMethod_ImplicitSpec_ObjFPC;
begin begin
StartProgram(false); StartProgram(false);

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

@ -830,7 +830,6 @@ type
Procedure TestRTTI_Class_OtherUnit_TypeAlias; Procedure TestRTTI_Class_OtherUnit_TypeAlias;
Procedure TestRTTI_Class_OmitRTTI; Procedure TestRTTI_Class_OmitRTTI;
Procedure TestRTTI_Class_Field_AnonymousArrayOfSelfClass; Procedure TestRTTI_Class_Field_AnonymousArrayOfSelfClass;
Procedure TestRTTI_Class_Field_AnonymousArrayOfSelfClass2;
Procedure TestRTTI_IndexModifier; Procedure TestRTTI_IndexModifier;
Procedure TestRTTI_StoredModifier; Procedure TestRTTI_StoredModifier;
Procedure TestRTTI_DefaultValue; Procedure TestRTTI_DefaultValue;