pastojs: specialzie anonymous function

git-svn-id: trunk@49093 -

packages/fcl-passrc/src/pasresolver.pp

@@ -17947,7 +17947,7 @@ begin
 
   if GenEl.Body<>nil then
     begin
-    // implementation proc
+    // implementation or anonymous proc
     if SpecializedItem<>nil then
       SpecializedItem.Step:=prssImplementationBuilding;
     GenBody:=GenEl.Body;
@@ -18435,11 +18435,21 @@ begin
 end;
 
 procedure TPasResolver.SpecializeProcedureExpr(GenEl, SpecEl: TProcedureExpr);
+var
+  GenProc: TPasAnonymousProcedure;
+  NewClass: TPTreeElement;
 begin
   SpecializeExpr(GenEl,SpecEl);
-  if GenEl.Proc=nil then
+  GenProc:=GenEl.Proc;
+  if GenProc=nil then
     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;
 
 procedure TPasResolver.SpecializeResString(GenEl, SpecEl: TPasResString);

packages/pastojs/tests/tcgenerics.pas

@@ -75,6 +75,7 @@ type
     procedure TestGenProc_TypeInfo;
     procedure TestGenProc_Infer_Widen;
     procedure TestGenProc_Infer_PassAsArg;
+    procedure TestGenProc_AnonymousProc;
     // ToDo: FuncName:= instead of Result:=
 
     // generic methods
@@ -2216,6 +2217,64 @@ begin
     '']));
 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;
 begin
   StartProgram(false);

packages/pastojs/tests/tcmodules.pas

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