pastojs: typecast procvar and pointer, name anonymous array type

git-svn-id: trunk@35809 -

packages/pastojs/src/fppas2js.pp

@@ -238,9 +238,9 @@ Works:
   - use 0o for octal literals
 
 ToDos:
-- nicer error message on "array of array of ()"
-- move local types to unit scope
+- typecast proctype
 - RTTI
+  - open array param
   - codetools function typeinfo
   - jsinteger (pasresolver: btIntDouble)
   - class property
@@ -249,6 +249,7 @@ ToDos:
   - typinfo.pp functions to get/setprop
   - documentation
 - warn int64
+- move local types to unit scope
 - local var absolute
 - make -Jirtl.js default for -Jc and -Tnodejs, needs #IFDEF in cfg
 - FuncName:= (instead of Result:=)
@@ -444,7 +445,7 @@ type
     pbivnRTTIPropStored,
     pbivnRTTISet_CompType,
     pbivnWith,
-    pbitnAnonymEnum,
+    pbitnAnonymousPostfix,
     pbitnTI,
     pbitnTIClass,
     pbitnTIClassRef,
@@ -534,7 +535,7 @@ const
     'stored',
     'comptype',
     '$with',
-    '$enum',
+    '$a',
     'tTypeInfo',
     'tTypeInfoClass',
     'tTypeInfoClassRef',
@@ -781,7 +782,8 @@ const
     proClassOfIs,
     proExtClassInstanceNoTypeMembers,
     proOpenAsDynArrays,
-    proProcTypeWithoutIsNested
+    proProcTypeWithoutIsNested,
+    proMethodAddrAsPointer
     ];
 type
   TPas2JSResolver = class(TPasResolver)
@@ -1178,7 +1180,7 @@ type
     Function ConvertExternalConstructor(Left: TPasElement;
       Ref: TResolvedReference; ParamsExpr: TParamsExpr;
       AContext : TConvertContext): TJSElement; virtual;
-    Function ConvertTypeCastToBaseType(El: TParamsExpr; AContext: TConvertContext; BaseTypeData: TResElDataBaseType): TJSElement; virtual;
+    Function ConvertTypeCastToBaseType(El: TParamsExpr; AContext: TConvertContext; ToBaseTypeData: TResElDataBaseType): TJSElement; virtual;
     Function ConvertSetLiteral(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertOpenArrayParam(ElType: TPasType; El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBuiltIn_Length(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
@@ -2499,7 +2501,7 @@ begin
   ScopeClass_WithExpr:=TPas2JSWithExprScope;
   for bt in [pbtJSValue] do
     AddJSBaseType(Pas2jsBaseTypeNames[bt],bt);
-  AnonymousEnumtypePostfix:=Pas2JSBuiltInNames[pbitnAnonymEnum];
+  AnonymousElTypePostfix:=Pas2JSBuiltInNames[pbitnAnonymousPostfix];
 end;
 
 destructor TPas2JSResolver.Destroy;
@@ -2585,11 +2587,8 @@ begin
             Result:=cExact+1 // type cast JSValue to simple base type
           else if ToResolved.BaseType=btContext then
             begin
-            C:=ToResolved.TypeEl.ClassType;
-            if (C=TPasClassType)
-                or (C=TPasClassOfType)
-                or (C=TPasEnumType) then
-              Result:=cExact+1;
+            // typecast JSValue to user type
+            Result:=cExact+1;
             end;
           end;
         exit;
@@ -4975,7 +4974,7 @@ var
   Elements: TJSArrayLiteralElements;
   E: TJSArrayLiteral;
   OldAccess: TCtxAccess;
-  DeclResolved, ParamResolved: TPasResolverResult;
+  DeclResolved, ParamResolved, ValueResolved: TPasResolverResult;
   Param: TPasExpr;
   JSBaseType: TPas2jsBaseType;
   C: TClass;
@@ -5106,7 +5105,19 @@ begin
     else if (C=TPasProcedureType)
         or (C=TPasFunctionType) then
       begin
-      TargetProcType:=TPasProcedureType(Decl);
+      AContext.Resolver.ComputeElement(El.Value,ValueResolved,[rcNoImplicitProc]);
+      if ValueResolved.IdentEl is TPasProcedureType then
+        begin
+         // type cast to proc type
+        Param:=El.Params[0];
+        Result:=ConvertElement(Param,AContext);
+        exit;
+        end
+      else
+        begin
+        // calling proc var
+        TargetProcType:=TPasProcedureType(Decl);
+        end;
       end
     else
       begin
@@ -5236,9 +5247,9 @@ begin
 end;
 
 function TPasToJSConverter.ConvertTypeCastToBaseType(El: TParamsExpr;
-  AContext: TConvertContext; BaseTypeData: TResElDataBaseType): TJSElement;
+  AContext: TConvertContext; ToBaseTypeData: TResElDataBaseType): TJSElement;
 var
-  bt: TResolverBaseType;
+  to_bt: TResolverBaseType;
   Param: TPasExpr;
   ParamResolved: TPasResolverResult;
   NotEqual: TJSEqualityExpressionNE;
@@ -5271,8 +5282,8 @@ begin
   JSBaseTypeData:=nil;
   JSBaseType:=pbtNone;
 
-  bt:=BaseTypeData.BaseType;
-  if bt in btAllInteger then
+  to_bt:=ToBaseTypeData.BaseType;
+  if to_bt in btAllInteger then
     begin
     if ParamResolved.BaseType in btAllInteger then
       begin
@@ -5307,7 +5318,7 @@ begin
         end;
       end;
     end
-  else if bt in btAllBooleans then
+  else if to_bt in btAllBooleans then
     begin
     if ParamResolved.BaseType in btAllBooleans then
       begin
@@ -5342,7 +5353,7 @@ begin
         end;
       end;
     end
-  else if bt in btAllFloats then
+  else if to_bt in btAllFloats then
     begin
     if ParamResolved.BaseType in (btAllFloats+btAllInteger) then
       begin
@@ -5365,7 +5376,7 @@ begin
         end;
       end;
     end
-  else if bt in btAllStrings then
+  else if to_bt in btAllStrings then
     begin
     if ParamResolved.BaseType in btAllStringAndChars then
       begin
@@ -5388,7 +5399,7 @@ begin
         end;
       end;
     end
-  else if bt=btChar then
+  else if to_bt=btChar then
     begin
     if ParamResolved.BaseType=btChar then
       begin
@@ -5411,7 +5422,7 @@ begin
         end;
       end;
     end
-  else if bt=btPointer then
+  else if to_bt=btPointer then
     begin
     if IsParamPas2JSBaseType then
       begin
@@ -5421,11 +5432,17 @@ begin
         Result:=ConvertElement(Param,AContext);
         exit;
         end;
+      end
+    else if ParamResolved.BaseType=btContext then
+      begin
+      // convert user type/value to pointer -> pass through
+      Result:=ConvertElement(Param,AContext);
+      exit;
       end;
     end
-  else if (bt=btCustom) and (BaseTypeData is TResElDataPas2JSBaseType) then
+  else if (to_bt=btCustom) and (ToBaseTypeData is TResElDataPas2JSBaseType) then
     begin
-    JSBaseType:=TResElDataPas2JSBaseType(BaseTypeData).JSBaseType;
+    JSBaseType:=TResElDataPas2JSBaseType(ToBaseTypeData).JSBaseType;
     if JSBaseType=pbtJSValue then
       begin
       // type cast to jsvalue
@@ -5448,7 +5465,7 @@ begin
       end;
     end;
   {$IFDEF VerbosePas2JS}
-  writeln('TPasToJSConverter.ConvertTypeCastToBaseType BaseTypeData=',BaseTypeNames[bt],' ParamResolved=',GetResolverResultDesc(ParamResolved));
+  writeln('TPasToJSConverter.ConvertTypeCastToBaseType BaseTypeData=',BaseTypeNames[to_bt],' ParamResolved=',GetResolverResultDesc(ParamResolved));
   {$ENDIF}
   RaiseNotSupported(El,AContext,20170325161150);
 end;

packages/pastojs/tests/tcmodules.pas

@@ -403,9 +403,11 @@ type
     Procedure TestProcType_PropertyDelphi;
     Procedure TestProcType_WithClassInstDoPropertyFPC;
     Procedure TestProcType_Nested;
+    Procedure TestProcType_Typecast;
 
     // pointer
     Procedure TestPointer;
+    Procedure TestPointer_Proc;
     Procedure TestPointer_AssignRecordFail;
     Procedure TestPointer_AssignStaticArrayFail;
     Procedure TestPointer_ArrayParamsFail;
@@ -431,6 +433,7 @@ type
     Procedure TestRTTI_AnonymousEnumType;
     Procedure TestRTTI_StaticArray;
     Procedure TestRTTI_DynArray;
+    Procedure TestRTTI_ArrayNestedAnonymous;
     // ToDo: Procedure TestRTTI_Pointer;
     Procedure TestRTTI_PublishedMethodOverloadFail;
     Procedure TestRTTI_PublishedMethodExternalFail;
@@ -3192,28 +3195,28 @@ begin
   ConvertProgram;
   CheckSource('TestSet_AnonymousEnumType',
     LinesToStr([ // statements
-    'this.TFlags$enum = {',
+    'this.TFlags$a = {',
     '  "0": "red",',
     '  red: 0,',
     '  "1": "green",',
     '  green: 1',
     '};',
-    'this.favorite = this.TFlags$enum.red;',
+    'this.favorite = this.TFlags$a.red;',
     'this.f = {};',
     'this.i = 0;',
     '']),
     LinesToStr([
-    'this.f = rtl.includeSet(this.f, this.TFlags$enum.red);',
+    'this.f = rtl.includeSet(this.f, this.TFlags$a.red);',
     'this.f = rtl.includeSet(this.f, this.favorite);',
-    'this.i = this.TFlags$enum.red;',
+    'this.i = this.TFlags$a.red;',
     'this.i = this.favorite;',
-    'this.i = this.TFlags$enum.red;',
-    'this.i = this.TFlags$enum.red;',
-    'this.i = this.TFlags$enum.red;',
-    'this.i = this.TFlags$enum.green;',
-    'this.i = this.TFlags$enum.green;',
-    'this.i = this.TFlags$enum.green;',
-    'this.f = rtl.createSet(this.TFlags$enum.green, this.favorite);',
+    'this.i = this.TFlags$a.red;',
+    'this.i = this.TFlags$a.red;',
+    'this.i = this.TFlags$a.red;',
+    'this.i = this.TFlags$a.green;',
+    'this.i = this.TFlags$a.green;',
+    'this.i = this.TFlags$a.green;',
+    'this.f = rtl.createSet(this.TFlags$a.green, this.favorite);',
     '']));
 end;
 
@@ -6916,10 +6919,9 @@ begin
   Add('  obj:=tcontrol(obj).next;');
   Add('  tcontrol(obj):=nil;');
   Add('  obj:=tcontrol(obj);');
-  Add('  tcontrol(obj):=tcontrol(tcontrol(obj).getit);');
   Add('  tcontrol(obj):=tcontrol(tcontrol(obj).getit());');
   Add('  tcontrol(obj):=tcontrol(tcontrol(obj).getit(1));');
-  Add('  tcontrol(obj):=tcontrol(tcontrol(tcontrol(obj).getit).arr[2]);');
+  Add('  tcontrol(obj):=tcontrol(tcontrol(tcontrol(obj).getit()).arr[2]);');
   ConvertProgram;
   CheckSource('TestClass_TypeCast',
     LinesToStr([ // statements
@@ -6954,7 +6956,6 @@ begin
     'this.Obj = null;',
     'this.Obj = this.Obj;',
     'this.Obj = this.Obj.GetIt(0);',
-    'this.Obj = this.Obj.GetIt(0);',
     'this.Obj = this.Obj.GetIt(1);',
     'this.Obj = this.Obj.GetIt(0).Arr[2];',
     '']));
@@ -10025,6 +10026,62 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestProcType_Typecast;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  TNotifyEvent = procedure(Sender: Pointer) of object;');
+  Add('  TEvent = procedure of object;');
+  Add('  TProcA = procedure(i: longint);');
+  Add('  TFuncB = function(i, j: longint): longint;');
+  Add('var');
+  Add('  Notify: TNotifyEvent;');
+  Add('  Event: TEvent;');
+  Add('  ProcA: TProcA;');
+  Add('  FuncB: TFuncB;');
+  Add('  p: pointer;');
+  Add('begin');
+  Add('  Notify:=TNotifyEvent(Event);');
+  Add('  Event:=TEvent(Event);');
+  Add('  Event:=TEvent(Notify);');
+  Add('  ProcA:=TProcA(FuncB);');
+  Add('  FuncB:=TFuncB(FuncB);');
+  Add('  FuncB:=TFuncB(ProcA);');
+  Add('  ProcA:=TProcA(p);');
+  Add('  FuncB:=TFuncB(p);');
+  Add('  p:=Pointer(Notify);');
+  Add('  p:=Notify;');
+  Add('  p:=Pointer(ProcA);');
+  Add('  p:=ProcA;');
+  Add('  p:=Pointer(FuncB);');
+  Add('  p:=FuncB;');
+  ConvertProgram;
+  CheckSource('TestProcType_Typecast',
+    LinesToStr([ // statements
+    'this.Notify = null;',
+    'this.Event = null;',
+    'this.ProcA = null;',
+    'this.FuncB = null;',
+    'this.p = null;',
+    '']),
+    LinesToStr([ // this.$main
+    'this.Notify = this.Event;',
+    'this.Event = this.Event;',
+    'this.Event = this.Notify;',
+    'this.ProcA = this.FuncB;',
+    'this.FuncB = this.FuncB;',
+    'this.FuncB = this.ProcA;',
+    'this.ProcA = this.p;',
+    'this.FuncB = this.p;',
+    'this.p = this.Notify;',
+    'this.p = this.Notify;',
+    'this.p = this.ProcA;',
+    'this.p = this.ProcA;',
+    'this.p = this.FuncB;',
+    'this.p = this.FuncB;',
+    '']));
+end;
+
 procedure TTestModule.TestPointer;
 begin
   StartProgram(false);
@@ -10084,6 +10141,40 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestPointer_Proc;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  TObject = class');
+  Add('    procedure DoIt; virtual; abstract;');
+  Add('  end;');
+  Add('procedure DoSome; begin end;');
+  Add('var');
+  Add('  o: TObject;');
+  Add('  p: Pointer;');
+  Add('begin');
+  Add('  p:=@DoSome;');
+  Add('  p:[email protected];');
+  ConvertProgram;
+  CheckSource('TestPointer_Proc',
+    LinesToStr([ // statements
+    'rtl.createClass(this, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'this.DoSome = function () {',
+    '};',
+    'this.o = null;',
+    'this.p = null;',
+    '']),
+    LinesToStr([ // this.$main
+    'this.p = rtl.createCallback(this, "DoSome");',
+    'this.p = rtl.createCallback(this.o, "DoIt");',
+    '']));
+end;
+
 procedure TTestModule.TestPointer_AssignRecordFail;
 begin
   StartProgram(false);
@@ -10959,24 +11050,24 @@ begin
   ConvertProgram;
   CheckSource('TestRTTI_AnonymousEnumType',
     LinesToStr([ // statements
-    'this.TFlags$enum = {',
+    'this.TFlags$a = {',
     '  "0": "red",',
     '  red: 0,',
     '  "1": "green",',
     '  green: 1',
     '};',
-    'this.$rtti.$Enum("TFlags$enum", {',
+    'this.$rtti.$Enum("TFlags$a", {',
     '  minvalue: 0,',
     '  maxvalue: 1,',
-    '  enumtype: this.TFlags$enum',
+    '  enumtype: this.TFlags$a',
     '});',
     'this.$rtti.$Set("TFlags", {',
-    '  comptype: this.$rtti["TFlags$enum"]',
+    '  comptype: this.$rtti["TFlags$a"]',
     '});',
     'this.f = {};',
     '']),
     LinesToStr([
-    'this.f = rtl.includeSet(this.f, this.TFlags$enum.red);',
+    'this.f = rtl.includeSet(this.f, this.TFlags$a.red);',
     '']));
 end;
 
@@ -11058,6 +11149,29 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestRTTI_ArrayNestedAnonymous;
+begin
+  Converter.Options:=Converter.Options-[coNoTypeInfo];
+  StartProgram(false);
+  Add('type');
+  Add('  TArr = array of array of longint;');
+  Add('var a: TArr;');
+  Add('begin');
+  ConvertProgram;
+  CheckSource('TestRTTI_ArrayNestedAnonymous',
+    LinesToStr([ // statements
+    'this.$rtti.$DynArray("TArr$a", {',
+    '  eltype: rtl.longint',
+    '});',
+    'this.$rtti.$DynArray("TArr", {',
+    '  eltype: this.$rtti["TArr$a"]',
+    '});',
+    'this.a = [];',
+    '']),
+    LinesToStr([ // this.$main
+    ]));
+end;
+
 procedure TTestModule.TestRTTI_PublishedMethodOverloadFail;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];