pastojs: added array params to external class 'Array' [integer]:jsvalue, 'Object' [string]:jsvalue

git-svn-id: trunk@35714 -

packages/pastojs/src/fppas2js.pp

@@ -187,6 +187,8 @@ Works:
   - Pascal descendant can override newinstance
   - any class can be typecasted to any root class
   - class instances cannot access external class members (e.g. static class functions)
+  - external class 'Array' bracket operator [integer] type jsvalue
+  - external class 'Object' bracket operator [string] type jsvalue
 - jsvalue
   - init as undefined
   - assign to jsvalue := integer, string, boolean, double, char
@@ -210,7 +212,6 @@ Works:
   - use 0o for octal literals
 
 ToDos:
-- [] operator of external class 'Array'
 - FuncName:= (instead of Result:=)
 - ord(s[i]) -> s.charCodeAt(i)
 - $modeswitch -> define <modeswitch>
@@ -662,6 +663,12 @@ 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;
   public
     constructor Create;
     destructor Destroy; override;
@@ -672,17 +679,17 @@ type
     function CheckTypeCastRes(const FromResolved,
       ToResolved: TPasResolverResult; ErrorEl: TPasElement;
       RaiseOnError: boolean): integer; override;
+    property JSBaseTypes[aBaseType: TPas2jsBaseType]: TPasUnresolvedSymbolRef read GetJSBaseTypes;
     // compute literals and constants
-    Function ExtractPasStringLiteral(El: TPasElement; const S: String): TJSString; virtual;
-    Function ComputeConst(Expr: TPasExpr; StoreCustomData: boolean): TJSValue; virtual;
-    Function ComputeConstString(Expr: TPasExpr; StoreCustomData, NotEmpty: boolean): String; virtual;
+    function ExtractPasStringLiteral(El: TPasElement; const S: String): TJSString; virtual;
+    function ComputeConst(Expr: TPasExpr; StoreCustomData: boolean): TJSValue; virtual;
+    function ComputeConstString(Expr: TPasExpr; StoreCustomData, NotEmpty: boolean): String; virtual;
     // CustomData
     function GetElementData(El: TPasElementBase;
       DataClass: TPas2JsElementDataClass): TPas2JsElementData; virtual;
     procedure AddElementData(Data: TPas2JsElementData); virtual;
     function CreateElementData(DataClass: TPas2JsElementDataClass;
       El: TPasElement): TPas2JsElementData; virtual;
-    property JSBaseTypes[aBaseType: TPas2jsBaseType]: TPasUnresolvedSymbolRef read GetJSBaseTypes;
   end;
 
 //------------------------------------------------------------------------------
@@ -1912,6 +1919,77 @@ 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);
+      FinishParamExpressionAccess(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);
+      FinishParamExpressionAccess(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;
+
 constructor TPas2JSResolver.Create;
 var
   bt: TPas2jsBaseType;
@@ -2018,10 +2096,10 @@ begin
         ToClass:=TPasClassType(ToResolved.TypeEl);
         if ToClass.IsExternal then
           begin
-          if (ToClass.ExternalName='String')
+          if IsExternalClassName(ToClass,'String')
               and (FromResolved.BaseType in btAllStringAndChars) then
             exit(cExact);
-          if (ToClass.ExternalName='Array')
+          if IsExternalClassName(ToClass,'Array')
               and ((FromResolved.BaseType=btArray)
                   or (FromResolved.BaseType=btContext)) then
             exit(cExact);
@@ -2032,7 +2110,7 @@ begin
         if (FromResolved.BaseType=btContext)
             and (FromResolved.TypeEl.ClassType=TPasClassType)
             and TPasClassType(FromResolved.TypeEl).IsExternal
-            and (TPasClassType(FromResolved.TypeEl).ExternalName='Array') then
+            and IsExternalClassName(TPasClassType(FromResolved.TypeEl),'Array') then
           begin
             // type cast external Array to an array
             exit(cExact+1);
@@ -3876,7 +3954,7 @@ var
         for i:=1 to Max(length(ArrayEl.Ranges),1) do
           begin
           // add parameter
-          AContext.Access:=caRead;
+          ArgContext.Access:=caRead;
           Arg:=ConvertElement(El.Params[ArgNo],ArgContext);
           ArgContext.Access:=OldAccess;
           if B.Name<>nil then
@@ -3902,6 +3980,31 @@ var
     end;
   end;
 
+  procedure ConvertJSObject;
+  var
+    B: TJSBracketMemberExpression;
+    OldAccess: TCtxAccess;
+  begin
+    B:=TJSBracketMemberExpression(CreateElement(TJSBracketMemberExpression,El));
+    try
+      // add read accessor
+      OldAccess:=AContext.Access;
+      AContext.Access:=caRead;
+      B.MExpr:=ConvertElement(El.Value,AContext);
+      AContext.Access:=OldAccess;
+
+      // add parameter
+      ArgContext.Access:=caRead;
+      B.Name:=ConvertElement(El.Params[0],ArgContext);
+      ArgContext.Access:=OldAccess;
+
+      Result:=B;
+    finally
+      if Result=nil then
+        B.Free;
+    end;
+  end;
+
   procedure ConvertIndexProperty(Prop: TPasProperty; AContext: TConvertContext);
   var
     Call: TJSCallExpression;
@@ -4013,6 +4116,7 @@ Var
   ClassScope: TPas2JSClassScope;
   B: TJSBracketMemberExpression;
   OldAccess: TCtxAccess;
+  aClass: TPasClassType;
 begin
   if El.Kind<>pekArrayParams then
     RaiseInconsistency(20170209113713);
@@ -4059,10 +4163,15 @@ begin
     TypeEl:=ResolvedEl.TypeEl;
     if TypeEl.ClassType=TPasClassType then
       begin
+      aClass:=TPasClassType(TypeEl);
       ClassScope:=TypeEl.CustomData as TPas2JSClassScope;
-      if ClassScope.DefaultProperty=nil then
+      if ClassScope.DefaultProperty<>nil then
+        ConvertDefaultProperty(ClassScope.DefaultProperty)
+      else if AContext.Resolver.IsExternalClassName(aClass,'Array')
+          or AContext.Resolver.IsExternalClassName(aClass,'Object') then
+        ConvertJSObject
+      else
         RaiseInconsistency(20170206180448);
-      ConvertDefaultProperty(ClassScope.DefaultProperty);
       end
     else if TypeEl.ClassType=TPasClassOfType then
       begin

packages/pastojs/tests/tcmodules.pas

@@ -360,6 +360,7 @@ type
     Procedure TestExternalClass_LocalConstSameName;
     Procedure TestExternalClass_ReintroduceOverload;
     Procedure TestExternalClass_Inherited;
+    Procedure TestExternalClass_PascalAncestorFail;
     Procedure TestExternalClass_NewInstance;
     Procedure TestExternalClass_NewInstance_NonVirtualFail;
     Procedure TestExternalClass_NewInstance_FirstParamNotString_Fail;
@@ -367,6 +368,7 @@ type
     Procedure TestExternalClass_TypeCastToRootClass;
     Procedure TestExternalClass_TypeCastStringToExternalString;
     Procedure TestExternalClass_CallClassFunctionOfInstanceFail;
+    Procedure TestExternalClass_BracketOperator;
 
     // proc types
     Procedure TestProcType;
@@ -8287,6 +8289,20 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestExternalClass_PascalAncestorFail;
+begin
+  StartProgram(false);
+  Add('{$modeswitch externalclass}');
+  Add('type');
+  Add('  TObject = class');
+  Add('  end;');
+  Add('  TExtA = class external name ''ExtA''(TObject)');
+  Add('  end;');
+  Add('begin');
+  SetExpectedPasResolverError('Ancestor "TObject" is not external',nAncestorIsNotExternal);
+  ConvertProgram;
+end;
+
 procedure TTestModule.TestExternalClass_NewInstance;
 begin
   StartProgram(false);
@@ -8483,6 +8499,93 @@ begin
   ConvertProgram;
 end;
 
+procedure TTestModule.TestExternalClass_BracketOperator;
+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.TestProcType;
 begin
   StartProgram(false);