pastojs:

- typeinfo(varclass) is converted to varclass.$rtti
- removed workaround for external 'Object' and 'Array' [] operator

git-svn-id: trunk@35799 -

packages/pastojs/src/fppas2js.pp

@@ -228,6 +228,7 @@ Works:
   - record type  tkRecord
   - no typeinfo for local types
   - built-in function typeinfo(): Pointer/TTypeInfo/...;
+    - typeinfo(class) -> class.$rtti
   - WPO skip not used typeinfo
 - pointer
   - compare with and assign nil
@@ -236,20 +237,18 @@ Works:
   - use 0o for octal literals
 
 ToDos:
+- move pas.System calls from rtl.js to system unit initialization, because of
+  UseLowerCase and WPO
 - RTTI
   - codetools function typeinfo
   - jsinteger (pasresolver: btIntDouble)
   - class property
-    - indexed property
     - defaultvalue
   - type alias type
   - typinfo.pp functions to get/setprop
-- move pas.System calls from rtl.js to system unit initialization
 - warn int64
 - local var absolute
 - make -Jirtl.js default for -Jc and -Tnodejs, needs #IFDEF in cfg
-- remove 'Object' array workaround
-- use TJSObject[] for RegisterClass
 - FuncName:= (instead of Result:=)
 - $modeswitch -> define <modeswitch>
 - $modeswitch- -> turn off
@@ -277,6 +276,7 @@ Not in Version 1.0:
   - set of (enum,enum2)  - anonymous enumtype
 - call array of proc element without ()
 - record const
+- class: property modifier index
 - enums with custom values
 - library
 - option typecast checking
@@ -824,12 +824,6 @@ type
     function CheckEqualCompatibilityCustomType(const LHS,
       RHS: TPasResolverResult; ErrorEl: TPasElement;
       RaiseOnIncompatible: boolean): integer; override;
-    function ResolveBracketOperatorClass(Params: TParamsExpr;
-      const ResolvedValue: TPasResolverResult; ClassScope: TPasClassScope;
-      Access: TResolvedRefAccess): boolean; override;
-    procedure ComputeArrayParams_Class(Params: TParamsExpr; var
-      ResolvedEl: TPasResolverResult; ClassScope: TPasClassScope;
-      Flags: TPasResolverComputeFlags; StartEl: TPasElement); override;
     procedure BI_TypeInfo_OnGetCallResult(Proc: TResElDataBuiltInProc;
       Params: TParamsExpr; out ResolvedEl: TPasResolverResult); override;
   public
@@ -2353,77 +2347,6 @@ begin
     RaiseInternalError(20170330005725);
 end;
 
-function TPas2JSResolver.ResolveBracketOperatorClass(Params: TParamsExpr;
-  const ResolvedValue: TPasResolverResult; ClassScope: TPasClassScope;
-  Access: TResolvedRefAccess): boolean;
-var
-  ParamResolved: TPasResolverResult;
-  Param: TPasExpr;
-  aClass: TPasClassType;
-begin
-  if ClassScope.DefaultProperty=nil then
-    begin
-    aClass:=TPasClassType(ClassScope.Element);
-    if IsExternalClassName(aClass,'Array') then
-      begin
-      if ResolvedValue.IdentEl is TPasType then
-        RaiseMsg(20170402194000,nIllegalQualifier,sIllegalQualifier,['['],Params);
-      if length(Params.Params)<>1 then
-        RaiseMsg(20170402194059,nWrongNumberOfParametersForArray,
-          sWrongNumberOfParametersForArray,[],Params);
-      // check first param is an integer value
-      Param:=Params.Params[0];
-      ComputeElement(Param,ParamResolved,[]);
-      if (not (rrfReadable in ParamResolved.Flags))
-          or not (ParamResolved.BaseType in btAllInteger) then
-        CheckRaiseTypeArgNo(20170402194221,1,Param,ParamResolved,'integer',true);
-      AccessExpr(Param,rraRead);
-      exit(true);
-      end
-    else if IsExternalClassName(aClass,'Object') then
-      begin
-      if ResolvedValue.IdentEl is TPasType then
-        RaiseMsg(20170402194453,nIllegalQualifier,sIllegalQualifier,['['],Params);
-      if length(Params.Params)<>1 then
-        RaiseMsg(20170402194456,nWrongNumberOfParametersForArray,
-          sWrongNumberOfParametersForArray,[],Params);
-      // check first param is a string value
-      Param:=Params.Params[0];
-      ComputeElement(Param,ParamResolved,[]);
-      if (not (rrfReadable in ParamResolved.Flags))
-          or not (ParamResolved.BaseType in btAllStringAndChars) then
-        CheckRaiseTypeArgNo(20170402194511,1,Param,ParamResolved,'string',true);
-      AccessExpr(Param,rraRead);
-      exit(true);
-      end;
-    end;
-  Result:=inherited ResolveBracketOperatorClass(Params, ResolvedValue, ClassScope, Access);
-end;
-
-procedure TPas2JSResolver.ComputeArrayParams_Class(Params: TParamsExpr;
-  var ResolvedEl: TPasResolverResult; ClassScope: TPasClassScope;
-  Flags: TPasResolverComputeFlags; StartEl: TPasElement);
-var
-  aClass: TPasClassType;
-  OrigResolved: TPasResolverResult;
-begin
-  aClass:=TPasClassType(ClassScope.Element);
-  if IsExternalClassName(aClass,'Array') or IsExternalClassName(aClass,'Object') then
-    begin
-    if [rcConstant,rcType]*Flags<>[] then
-      RaiseConstantExprExp(20170402202137,Params);
-    OrigResolved:=ResolvedEl;
-    SetResolverTypeExpr(ResolvedEl,btCustom,JSBaseTypes[pbtJSValue],[rrfReadable,rrfWritable]);
-    // identifier and value is the array/object itself
-    ResolvedEl.IdentEl:=OrigResolved.IdentEl;
-    ResolvedEl.ExprEl:=OrigResolved.ExprEl;
-    ResolvedEl.Flags:=OrigResolved.Flags+[rrfReadable,rrfWritable];
-    exit;
-    end;
-  inherited ComputeArrayParams_Class(Params, ResolvedEl, ClassScope, Flags,
-    StartEl);
-end;
-
 procedure TPas2JSResolver.BI_TypeInfo_OnGetCallResult(
   Proc: TResElDataBuiltInProc; Params: TParamsExpr; out
   ResolvedEl: TPasResolverResult);
@@ -4992,12 +4915,9 @@ begin
     if TypeEl.ClassType=TPasClassType then
       begin
       aClass:=TPasClassType(TypeEl);
-      ClassScope:=TypeEl.CustomData as TPas2JSClassScope;
+      ClassScope:=aClass.CustomData as TPas2JSClassScope;
       if ClassScope.DefaultProperty<>nil then
         ConvertDefaultProperty(ResolvedEl,ClassScope.DefaultProperty)
-      else if AContext.Resolver.IsExternalClassName(aClass,'Array')
-          or AContext.Resolver.IsExternalClassName(aClass,'Object') then
-        ConvertJSObject
       else
         RaiseInconsistency(20170206180448);
       end
@@ -6579,7 +6499,19 @@ begin
   if ParamResolved.IdentEl is TPasType then
     Result:=CreateTypeInfoRef(TPasType(ParamResolved.IdentEl),AContext,Param)
   else if ParamResolved.TypeEl<>nil then
-    Result:=CreateTypeInfoRef(ParamResolved.TypeEl,AContext,Param)
+    begin
+    if (ParamResolved.TypeEl.ClassType=TPasClassType)
+        and (rrfReadable in ParamResolved.Flags)
+        and ((ParamResolved.IdentEl is TPasVariable)
+          or (ParamResolved.IdentEl.ClassType=TPasArgument)) then
+      begin
+      // typeinfo(classinstance) -> classinstance.$rtti
+      Result:=ConvertElement(Param,AContext);
+      Result:=CreateDotExpression(El,Result,CreateBuiltInIdentifierExpr(FBuiltInNames[pbivnRTTI]));
+      end
+    else
+      Result:=CreateTypeInfoRef(ParamResolved.TypeEl,AContext,Param);
+    end
   else
     RaiseNotSupported(El,AContext,20170413001544);
 end;

packages/pastojs/tests/tcmodules.pas

@@ -381,7 +381,6 @@ type
     Procedure TestExternalClass_TypeCastToRootClass;
     Procedure TestExternalClass_TypeCastStringToExternalString;
     Procedure TestExternalClass_CallClassFunctionOfInstanceFail;
-    Procedure TestExternalClass_BracketOperatorOld;
     Procedure TestExternalClass_BracketAccessor;
     Procedure TestExternalClass_BracketAccessor_2ParamsFail;
     Procedure TestExternalClass_BracketAccessor_ReadOnly;
@@ -435,6 +434,7 @@ type
     Procedure TestRTTI_Class_Field;
     Procedure TestRTTI_Class_Method;
     Procedure TestRTTI_Class_Property;
+    Procedure TestRTTI_Class_PropertyParams;
     // ToDo: property default value
     Procedure TestRTTI_OverrideMethod;
     Procedure TestRTTI_OverloadProperty;
@@ -447,6 +447,7 @@ type
     Procedure TestRTTI_TypeInfo_LocalFail;
     Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses1;
     Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses2;
+    Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses3;
   end;
 
 function LinesToStr(Args: array of const): string;
@@ -8837,93 +8838,6 @@ begin
   ConvertProgram;
 end;
 
-procedure TTestModule.TestExternalClass_BracketOperatorOld;
-begin
-  StartProgram(false);
-  Add('{$modeswitch externalclass}');
-  Add('type');
-  Add('  TJSArray = class external name ''Array''');
-  Add('  end;');
-  Add('  TJSObject = class external name ''Object''');
-  Add('  end;');
-  Add('procedure DoIt(vI: JSValue; const vJ: jsvalue; var vK: jsvalue; out vL: jsvalue);');
-  Add('begin end;');
-  Add('var');
-  Add('  Obj: tjsobject;');
-  Add('  Arr: tjsarray;');
-  Add('  s: string;');
-  Add('  i: longint;');
-  Add('  v: jsvalue;');
-  Add('begin');
-  Add('  arr[1]:=s;');
-  Add('  arr[2]:=i;');
-  Add('  arr[3]:=arr[4];');
-  Add('  v:=arr[5];');
-  Add('  v:=obj[''one''];');
-  Add('  obj[''two'']:=i;');
-  Add('  obj[''three'']:=v;');
-  Add('  doit(arr[6],arr[7],arr[8],arr[9]);');
-  Add('  doit(obj[''10''],obj[''11''],obj[''12''],obj[''13'']);');
-  ConvertProgram;
-  CheckSource('TestExternalClass_BracketOperator',
-    LinesToStr([ // statements
-    'this.DoIt = function (vI, vJ, vK, vL) {',
-    '};',
-    'this.Obj = null;',
-    'this.Arr = null;',
-    'this.s = "";',
-    'this.i = 0;',
-    'this.v = undefined;',
-    '']),
-    LinesToStr([ // this.$main
-    'this.Arr[1] = this.s;',
-    'this.Arr[2] = this.i;',
-    'this.Arr[3] = this.Arr[4];',
-    'this.v = this.Arr[5];',
-    'this.v = this.Obj["one"];',
-    'this.Obj["two"] = this.i;',
-    'this.Obj["three"] = this.v;',
-    'this.DoIt(this.Arr[6], this.Arr[7], {',
-    '  a: 8,',
-    '  p: this.Arr,',
-    '  get: function () {',
-    '      return this.p[this.a];',
-    '    },',
-    '  set: function (v) {',
-    '      this.p[this.a] = v;',
-    '    }',
-    '}, {',
-    '  a: 9,',
-    '  p: this.Arr,',
-    '  get: function () {',
-    '      return this.p[this.a];',
-    '    },',
-    '  set: function (v) {',
-    '      this.p[this.a] = v;',
-    '    }',
-    '});',
-    ' this.DoIt(this.Obj["10"], this.Obj["11"], {',
-    '  a: "12",',
-    '  p: this.Obj,',
-    '  get: function () {',
-    '      return this.p[this.a];',
-    '    },',
-    '  set: function (v) {',
-    '      this.p[this.a] = v;',
-    '    }',
-    '}, {',
-    '  a: "13",',
-    '  p: this.Obj,',
-    '  get: function () {',
-    '      return this.p[this.a];',
-    '    },',
-    '  set: function (v) {',
-    '      this.p[this.a] = v;',
-    '    }',
-    '});',
-    '']));
-end;
-
 procedure TTestModule.TestExternalClass_BracketAccessor;
 begin
   StartProgram(false);
@@ -11104,7 +11018,7 @@ begin
     LinesToStr([ // this.$main
     'this.p = this.$rtti["TObject"];',
     'this.p = rtl.pointer;',
-    'this.p = this.$rtti["TObject"];',
+    'this.p = this.Obj.$rtti;',
     '']));
 end;
 
@@ -11205,6 +11119,41 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestRTTI_Class_PropertyParams;
+begin
+  Converter.Options:=Converter.Options-[coNoTypeInfo];
+  StartProgram(false);
+  Add('{$modeswitch externalclass}');
+  Add('type');
+  Add('  integer = longint;');
+  Add('  TObject = class');
+  Add('  private');
+  Add('    function GetItems(i: integer): tobject; virtual; abstract;');
+  Add('    procedure SetItems(i: integer; value: tobject); virtual; abstract;');
+  Add('    function GetValues(const i: integer; var b: boolean): char; virtual; abstract;');
+  Add('    procedure SetValues(const i: integer; var b: boolean; value: char); virtual; abstract;');
+  Add('  published');
+  Add('    property Items[Index: integer]: tobject read getitems write setitems;');
+  Add('    property Values[const keya: integer; var keyb: boolean]: char read getvalues write setvalues;');
+  Add('  end;');
+  Add('begin');
+  ConvertProgram;
+  CheckSource('TestRTTI_Class_PropertyParams',
+    LinesToStr([ // statements
+    'rtl.createClass(this, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  var $r = this.$rtti;',
+    '  $r.addProperty("Items", 3, $r, "GetItems", "SetItems");',
+    '  $r.addProperty("Values", 3, rtl.char, "GetValues", "SetValues");',
+    '});',
+    '']),
+    LinesToStr([ // this.$main
+    '']));
+end;
+
 procedure TTestModule.TestRTTI_OverrideMethod;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];
@@ -11341,7 +11290,7 @@ begin
     '']),
     LinesToStr([ // this.$main
     'this.p = this.$rtti["TBridge"];',
-    'this.p = this.$rtti["TBridge"];',
+    'this.p = this.b.$rtti;',
     '']));
 end;
 
@@ -11659,30 +11608,24 @@ begin
   Add('  TTypeInfoProcVar = class external name ''rtl.tTypeInfoProcVar''(TTypeInfo) end;');
   Add('  TMethod = procedure of object;');
   Add('  TTypeInfoMethodVar = class external name ''rtl.tTypeInfoMethodVar''(TTypeInfoProcVar) end;');
-  Add('  TRec = record end;');
-  Add('  TTypeInfoRecord = class external name ''rtl.tTypeInfoRecord''(TTypeInfo) end;');
-  Add('  TObject = class end;');
-  Add('  TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;');
-  Add('  TClass = class of tobject;');
-  Add('  TTypeInfoClassRef = class external name ''rtl.tTypeInfoClassRef''(TTypeInfo) end;');
-  Add('  TTypeInfoPointer = class external name ''rtl.tTypeInfoPointer''(TTypeInfo) end;');
   Add('var');
+  Add('  StaticArray: TStaticArr;');
   Add('  tiStaticArray: TTypeInfoStaticArray;');
+  Add('  DynArray: TDynArr;');
   Add('  tiDynArray: TTypeInfoDynArray;');
+  Add('  ProcVar: TProc;');
   Add('  tiProcVar: TTypeInfoProcVar;');
+  Add('  MethodVar: TMethod;');
   Add('  tiMethodVar: TTypeInfoMethodVar;');
-  Add('  tiRecord: TTypeInfoRecord;');
-  Add('  tiClass: TTypeInfoClass;');
-  Add('  tiClassRef: TTypeInfoClassRef;');
-  Add('  tiPointer: TTypeInfoPointer;');
   Add('begin');
+  Add('  tiStaticArray:=typeinfo(StaticArray);');
   Add('  tiStaticArray:=typeinfo(TStaticArr);');
+  Add('  tiDynArray:=typeinfo(DynArray);');
   Add('  tiDynArray:=typeinfo(TDynArr);');
+  Add('  tiProcVar:=typeinfo(ProcVar);');
   Add('  tiProcVar:=typeinfo(TProc);');
+  Add('  tiMethodVar:=typeinfo(MethodVar);');
   Add('  tiMethodVar:=typeinfo(TMethod);');
-  Add('  tiRecord:=typeinfo(TRec);');
-  Add('  tiClass:=typeinfo(TObject);');
-  Add('  tiClassRef:=typeinfo(TClass);');
   ConvertProgram;
   CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses2',
     LinesToStr([ // statements
@@ -11700,6 +11643,61 @@ begin
     '  procsig: rtl.newTIProcSig(null),',
     '  methodkind: 0',
     '});',
+    'this.StaticArray = rtl.arrayNewMultiDim([2], "");',
+    'this.tiStaticArray = null;',
+    'this.DynArray = [];',
+    'this.tiDynArray = null;',
+    'this.ProcVar = null;',
+    'this.tiProcVar = null;',
+    'this.MethodVar = null;',
+    'this.tiMethodVar = null;',
+    '']),
+    LinesToStr([ // this.$main
+    'this.tiStaticArray = this.$rtti["TStaticArr"];',
+    'this.tiStaticArray = this.$rtti["TStaticArr"];',
+    'this.tiDynArray = this.$rtti["TDynArr"];',
+    'this.tiDynArray = this.$rtti["TDynArr"];',
+    'this.tiProcVar = this.$rtti["TProc"];',
+    'this.tiProcVar = this.$rtti["TProc"];',
+    'this.tiMethodVar = this.$rtti["TMethod"];',
+    'this.tiMethodVar = this.$rtti["TMethod"];',
+    '']));
+end;
+
+procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses3;
+begin
+  Converter.Options:=Converter.Options-[coNoTypeInfo];
+  StartProgram(false);
+  Add('{$modeswitch externalclass}');
+  Add('type');
+  Add('  TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
+  Add('  TRec = record end;');
+  Add('  TTypeInfoRecord = class external name ''rtl.tTypeInfoRecord''(TTypeInfo) end;');
+  // ToDo: ^PRec
+  Add('  TObject = class end;');
+  Add('  TTypeInfoClass = class external name ''rtl.tTypeInfoClass''(TTypeInfo) end;');
+  Add('  TClass = class of tobject;');
+  Add('  TTypeInfoClassRef = class external name ''rtl.tTypeInfoClassRef''(TTypeInfo) end;');
+  Add('  TTypeInfoPointer = class external name ''rtl.tTypeInfoPointer''(TTypeInfo) end;');
+  Add('var');
+  Add('  Rec: trec;');
+  Add('  tiRecord: ttypeinforecord;');
+  Add('  Obj: tobject;');
+  Add('  tiClass: ttypeinfoclass;');
+  Add('  aClass: tclass;');
+  Add('  tiClassRef: ttypeinfoclassref;');
+  // ToDo: ^PRec
+  Add('  tiPointer: ttypeinfopointer;');
+  Add('begin');
+  Add('  tirecord:=typeinfo(trec);');
+  Add('  tirecord:=typeinfo(trec);');
+  Add('  ticlass:=typeinfo(obj);');
+  Add('  ticlass:=typeinfo(tobject);');
+  Add('  ticlassref:=typeinfo(aclass);');
+  Add('  ticlassref:=typeinfo(tclass);');
+  ConvertProgram;
+  CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses3',
+    LinesToStr([ // statements
     'this.TRec = function (s) {',
     '};',
     'this.$rtti.$Record("TRec", {});',
@@ -11712,23 +11710,21 @@ begin
     'this.$rtti.$ClassRef("TClass", {',
     '  instancetype: this.$rtti["TObject"]',
     '});',
-    'this.tiStaticArray = null;',
-    'this.tiDynArray = null;',
-    'this.tiProcVar = null;',
-    'this.tiMethodVar = null;',
+    'this.Rec = new this.TRec();',
     'this.tiRecord = null;',
+    'this.Obj = null;',
     'this.tiClass = null;',
+    'this.aClass = null;',
     'this.tiClassRef = null;',
     'this.tiPointer = null;',
     '']),
     LinesToStr([ // this.$main
-    'this.tiStaticArray = this.$rtti["TStaticArr"];',
-    'this.tiDynArray = this.$rtti["TDynArr"];',
-    'this.tiProcVar = this.$rtti["TProc"];',
-    'this.tiMethodVar = this.$rtti["TMethod"];',
     'this.tiRecord = this.$rtti["TRec"];',
+    'this.tiRecord = this.$rtti["TRec"];',
+    'this.tiClass = this.Obj.$rtti;',
     'this.tiClass = this.$rtti["TObject"];',
     'this.tiClassRef = this.$rtti["TClass"];',
+    'this.tiClassRef = this.$rtti["TClass"];',
     '']));
 end;
 

packages/pastojs/tests/tcoptimizations.pas

@@ -79,6 +79,7 @@ type
     procedure TestWPO_UseUnit;
     procedure TestWPO_ProgramPublicDeclaration;
     procedure TestWPO_RTTI_PublishedField;
+    procedure TestWPO_RTTI_TypeInfo;
   end;
 
 implementation
@@ -796,7 +797,7 @@ begin
   ActualSrc:=JSToStr(JSModule);
   ExpectedSrc:=LinesToStr([
     'rtl.module("program", ["system"], function () {',
-     'this.$rtti.$DynArray("TArrB", {',
+    'this.$rtti.$DynArray("TArrB", {',
     '  eltype: rtl.string',
     '});',
     '  rtl.createClass(this, "TObject", null, function () {',
@@ -820,6 +821,41 @@ begin
   CheckDiff('TestWPO_RTTI_PublishedField',ExpectedSrc,ActualSrc);
 end;
 
+procedure TTestOptimizations.TestWPO_RTTI_TypeInfo;
+var
+  ActualSrc, ExpectedSrc: String;
+begin
+  Converter.Options:=Converter.Options-[coNoTypeInfo];
+  StartProgram(true);
+  Add('type');
+  Add('  TArrA = array of char;');
+  Add('  TArrB = array of string;');
+  Add('var');
+  Add('  A: TArrA;');
+  Add('  B: TArrB;');
+  Add('  p: pointer;');
+  Add('begin');
+  Add('  A:=nil;');
+  Add('  p:=typeinfo(B);');
+  ConvertProgram;
+  ActualSrc:=JSToStr(JSModule);
+  ExpectedSrc:=LinesToStr([
+    'rtl.module("program", ["system"], function () {',
+    'this.$rtti.$DynArray("TArrB", {',
+    '  eltype: rtl.string',
+    '});',
+    '  this.A = [];',
+    '  this.B = [];',
+    '  this.p = null;',
+    '  this.$main = function () {',
+    '    this.A = [];',
+    '    this.p = this.$rtti["TArrB"];',
+    '  };',
+    '});',
+    '']);
+  CheckDiff('TestWPO_RTTI_TypeInfo',ExpectedSrc,ActualSrc);
+end;
+
 Initialization
   RegisterTests([TTestOptimizations]);
 end.