* Patch from Mattias Gaertner

  - concat(array1,array2,...)
  - jsvalue = and <>
  - allow no other string type except String
  - allow no other float type except Double

git-svn-id: trunk@35693 -

packages/pastojs/src/fppas2js.pp

@@ -22,6 +22,8 @@ Works:
 - uses list
 - use $impl for implementation declarations, can be disabled
 - interface vars
+  - only double, no other float type
+  - only string, no other string type
   - modifier public to protect from removing by optimizer
 - implementation vars
 - external vars
@@ -102,7 +104,7 @@ Works:
 - dynamic arrays
   - init as "arr = []"  arrays must never be null
   - SetLength(arr,len) becomes  arr = SetLength(arr,len,defaultvalue)
-  - length(), low(), high(), assigned()
+  - length(), low(), high(), assigned(), concat()
   - assign nil -> []  arrays must never be null
   - read, write element arr[index]
   - multi dimensional [index1,index2] -> [index1][index2]
@@ -194,19 +196,19 @@ Works:
   - class of: assign to jsvalue, typecast jsvalue to a class-of
   - array of jsvalue
   - parameter, result type, assign from/to untyped
+  - operators equal, not equal
 
 ToDos:
-- if jsvalue<>nil  jsvalue=nil
+- external class: class functions are static, forbid calling instance.classfunction
 - function copy(array): array
 - function copy(array,start): array
 - function copy(array,start,count): array
-- proc insert(const item,var array,const position)
+- proc insert(item,var array,const position)
 - proc delete(var array,const start,count)
-- function slice(array,count): array
-- function splice(var array, const start,deletecount,item1,item2,...): arrayofdeletedelements;
 - function concat(array1,array2,...): array
+- function splice(var array, const start,deletecount,item1,item2,...): arrayofdeletedelements;
 - allow type casting array to external class 'Array'
-- document "overload" modifier
+- allow type casting string to external class 'String'
 - test param const R: TRect  r.Left:=3 fails
 - FuncName:= (instead of Result:=)
 - ord(s[i]) -> s.charCodeAt(i)
@@ -221,10 +223,10 @@ ToDos:
 - enumeration  for..in..do
 - pointer of record
 - nested types in class
+- asm: pas() - useful for overloads and protect an identifier from optimization
 
 Not in Version 1.0:
 - write, writeln
-- asm: pas() - useful for overloads and protect an identifier from optimization
 - arrays
   - static array: non 0 start index, length
   - array of static array: setlength
@@ -315,6 +317,7 @@ resourcestring
 
 type
   TPas2JSBuiltInName = (
+    pbifnArray_Concat,
     pbifnArray_NewMultiDim,
     pbifnArray_SetLength,
     pbifnAs,
@@ -359,6 +362,7 @@ type
 
 const
   Pas2JSBuiltInNames: array[TPas2JSBuiltInName] of string = (
+    'arrayConcat', // rtl.arrayConcat
     'arrayNewMultiDim', // rtl.arrayNewMultiDim
     'arraySetLength', // rtl.arraySetLength
     'as', // rtl.as
@@ -649,6 +653,9 @@ type
       RaiseOnIncompatible: boolean): integer; override;
     function CheckTypeCastClassInstanceToClass(Param: TPasExpr;
       const FromClassRes, ToClassRes: TPasResolverResult): integer; override;
+    function CheckEqualCompatibilityCustomType(const LHS,
+      RHS: TPasResolverResult; ErrorEl: TPasElement;
+      RaiseOnIncompatible: boolean): integer; override;
   public
     constructor Create;
     destructor Destroy; override;
@@ -978,6 +985,8 @@ type
     Function ConvertBuiltInStrProc(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBuiltInStrFunc(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBuiltInStrParam(El: TPasExpr; AContext: TConvertContext; IsStrFunc, IsFirst: boolean): TJSElement; virtual;
+    Function ConvertBuiltInConcatArray(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
+    Function ConvertBuiltInCopyArray(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertRecordValues(El: TRecordValues; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertSelfExpression(El: TSelfExpr; AContext: TConvertContext): TJSElement; virtual;
     Function ConvertBinaryExpression(El: TBinaryExpr; AContext: TConvertContext): TJSElement; virtual;
@@ -1863,6 +1872,59 @@ begin
     Result:=cIncompatible;
 end;
 
+function TPas2JSResolver.CheckEqualCompatibilityCustomType(const LHS,
+  RHS: TPasResolverResult; ErrorEl: TPasElement; RaiseOnIncompatible: boolean
+  ): integer;
+var
+  LeftBaseType: TPas2jsBaseType;
+begin
+  Result:=cIncompatible;
+  if LHS.BaseType=btCustom then
+    begin
+    if not (LHS.TypeEl is TPasUnresolvedSymbolRef) then
+      begin
+      {$IFDEF VerbosePas2JS}
+      writeln('TPas2JSResolver.CheckEqualCompatibilityCustomType LHS=',GetResolverResultDesc(LHS));
+      {$ENDIF}
+      RaiseInternalError(20170330005841);
+      end;
+    if not (LHS.TypeEl.CustomData is TResElDataPas2JSBaseType) then
+      exit;
+    LeftBaseType:=TResElDataPas2JSBaseType(LHS.TypeEl.CustomData).JSBaseType;
+    if LeftBaseType=pbtJSValue then
+      begin
+      if (rrfReadable in LHS.Flags) then
+        begin
+        if (rrfReadable in RHS.Flags) then
+          begin
+          if RHS.BaseType in btAllJSValueSrcTypes then
+            Result:=cExact
+          else if RHS.BaseType=btCustom then
+            begin
+            if IsJSBaseType(RHS,pbtJSValue) then
+              Result:=cExact;
+            end
+          else if RHS.BaseType=btContext then
+            Result:=cExact+1;
+          end
+        else if RHS.BaseType=btContext then
+          begin
+          // right side is not a value
+          if RHS.IdentEl<>nil then
+            begin
+            if RHS.IdentEl.ClassType=TPasClassType then
+              Result:=cExact+1; // RHS is a class
+            end;
+          end;
+        end;
+      end;
+    end
+  else if RHS.BaseType=btCustom then
+    exit(CheckEqualCompatibilityCustomType(RHS,LHS,ErrorEl,RaiseOnIncompatible))
+  else
+    RaiseInternalError(20170330005725);
+end;
+
 constructor TPas2JSResolver.Create;
 var
   bt: TPas2jsBaseType;
@@ -1888,7 +1950,11 @@ procedure TPas2JSResolver.AddObjFPCBuiltInIdentifiers(
   const TheBaseTypes: TResolveBaseTypes;
   const TheBaseProcs: TResolverBuiltInProcs);
 begin
-  inherited AddObjFPCBuiltInIdentifiers(TheBaseTypes-btAllStrings+[btString], TheBaseProcs);
+  inherited AddObjFPCBuiltInIdentifiers(
+    TheBaseTypes
+    -btAllStrings+[btString] // allow only String
+    -btAllFloats+[btDouble] // allow only Double
+    ,TheBaseProcs);
 end;
 
 function TPas2JSResolver.ExtractPasStringLiteral(El: TPasElement;
@@ -3991,6 +4057,8 @@ begin
           bfSucc: Result:=ConvertBuiltInSucc(El,AContext);
           bfStrProc: Result:=ConvertBuiltInStrProc(El,AContext);
           bfStrFunc: Result:=ConvertBuiltInStrFunc(El,AContext);
+          bfConcatArray: Result:=ConvertBuiltInConcatArray(El,AContext);
+          bfCopyArray: Result:=ConvertBuiltInCopyArray(El,AContext);
         else
           RaiseNotSupported(El,AContext,20161130164955,'built in proc '+ResolverBuiltInProcNames[BuiltInProc.BuiltIn]);
         end;
@@ -5262,6 +5330,80 @@ begin
   end;
 end;
 
+function TPasToJSConverter.ConvertBuiltInConcatArray(El: TParamsExpr;
+  AContext: TConvertContext): TJSElement;
+// concat(array1, array2)
+var
+  Param0Resolved, ElTypeResolved: TPasResolverResult;
+  Param0: TPasExpr;
+  ArrayType: TPasArrayType;
+  Call: TJSCallExpression;
+  i: Integer;
+begin
+  if length(El.Params)<1 then
+    RaiseInconsistency(20170331000332);
+  if length(El.Params)=1 then
+    begin
+    // concat(array1)  ->  array1
+    {$IFDEF VerbosePas2JS}
+    writeln('TPasToJSConverter.ConvertBuiltInConcatArray Count=',length(El.Params));
+    {$ENDIF}
+    Result:=ConvertElement(El.Params[0],AContext);
+    end
+  else
+    begin
+    // concat(array1,array2,...)
+    Param0:=El.Params[0];
+    AContext.Resolver.ComputeElement(Param0,Param0Resolved,[]);
+    if Param0Resolved.BaseType<>btContext then
+      RaiseNotSupported(Param0,AContext,20170331000819);
+    if Param0Resolved.TypeEl.ClassType<>TPasArrayType then
+      RaiseNotSupported(Param0,AContext,20170331000846);
+    ArrayType:=TPasArrayType(Param0Resolved.TypeEl);
+    if length(ArrayType.Ranges)>0 then
+      RaiseNotSupported(Param0,AContext,20170331001021);
+    AContext.Resolver.ComputeElement(ArrayType.ElType,ElTypeResolved,[rcType]);
+    Call:=CreateCallExpression(El);
+    try
+      {$IFDEF VerbosePas2JS}
+      writeln('TPasToJSConverter.ConvertBuiltInConcatArray Count=',length(El.Params),' ElType=',GetResolverResultDesc(ElTypeResolved));
+      {$ENDIF}
+      if ElTypeResolved.BaseType=btContext then
+        begin
+        if ElTypeResolved.TypeEl.ClassType=TPasRecordType then
+          begin
+          // record: rtl.arrayConcat(RecordType,array1,array2,...)
+          Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FBuiltInNames[pbifnArray_Concat]]);
+          Call.Args.Elements.AddElement.Expr:=CreateReferencePathExpr(
+                                                ElTypeResolved.TypeEl,AContext);
+          end;
+        end
+      else if ElTypeResolved.BaseType=btSet then
+        begin
+        // set: rtl.arrayConcat("refSet",array1,array2,...)
+        Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],FBuiltInNames[pbifnArray_Concat]]);
+        Call.Args.Elements.AddElement.Expr:=CreateLiteralString(El,'refSet');
+        end;
+      if Call.Expr=nil then
+        // default: array1.concat(array2,...)
+        Call.Expr:=CreateDotExpression(El,ConvertElement(Param0,AContext),
+                                     CreateBuiltInIdentifierExpr('concat'));
+      for i:=1 to length(El.Params)-1 do
+        Call.Args.Elements.AddElement.Expr:=ConvertElement(El.Params[i],AContext);
+      Result:=Call;
+    finally
+      if Result=nil then
+        Call.Free;
+    end;
+    end;
+end;
+
+function TPasToJSConverter.ConvertBuiltInCopyArray(El: TParamsExpr;
+  AContext: TConvertContext): TJSElement;
+begin
+  Result:=nil;
+end;
+
 function TPasToJSConverter.ConvertRecordValues(El: TRecordValues;
   AContext: TConvertContext): TJSElement;
 

packages/pastojs/tests/tcmodules.pas

@@ -164,6 +164,8 @@ type
     // vars/const
     Procedure TestVarInt;
     Procedure TestVarBaseTypes;
+    Procedure TestBaseTypeSingleFail;
+    Procedure TestBaseTypeExtendedFail;
     Procedure TestConstBaseTypes;
     Procedure TestUnitImplVars;
     Procedure TestUnitImplConsts;
@@ -184,7 +186,10 @@ type
     Procedure TestString_SetLength;
     Procedure TestString_CharAt;
     Procedure TestStr;
-    Procedure TestAnsiStringFail;
+    Procedure TestBaseType_AnsiStringFail;
+    Procedure TestBaseType_UnicodeStringFail;
+    Procedure TestBaseType_ShortStringFail;
+    Procedure TestBaseType_RawByteStringFail;
 
     // alias types
     Procedure TestAliasTypeRef;
@@ -261,12 +266,14 @@ type
     Procedure TestArray_Dynamic_Nil;
     Procedure TestArray_DynMultiDimensional;
     Procedure TestArrayOfRecord;
+    // ToDo: Procedure TestArrayOfSet;
     Procedure TestArray_AsParams;
     Procedure TestArrayElement_AsParams;
     Procedure TestArrayElementFromFuncResult_AsParams;
     Procedure TestArrayEnumTypeRange;
     Procedure TestArray_SetLengthProperty;
     Procedure TestArray_OpenArrayOfString;
+    Procedure TestArray_Concat;
     // ToDo: const array
     // ToDo: SetLength(array of static array)
 
@@ -369,6 +376,7 @@ type
     // jsvalue
     Procedure TestJSValue_AssignToJSValue;
     Procedure TestJSValue_TypeCastToBaseType;
+    Procedure TestJSValue_Equal;
     Procedure TestJSValue_Enum;
     Procedure TestJSValue_ClassInstance;
     Procedure TestJSValue_ClassOf;
@@ -1236,6 +1244,22 @@ begin
     '');
 end;
 
+procedure TTestModule.TestBaseTypeSingleFail;
+begin
+  StartProgram(false);
+  Add('var s: single;');
+  SetExpectedPasResolverError('identifier not found "single"',nIdentifierNotFound);
+  ConvertProgram;
+end;
+
+procedure TTestModule.TestBaseTypeExtendedFail;
+begin
+  StartProgram(false);
+  Add('var e: extended;');
+  SetExpectedPasResolverError('identifier not found "extended"',nIdentifierNotFound);
+  ConvertProgram;
+end;
+
 procedure TTestModule.TestConstBaseTypes;
 begin
   StartProgram(false);
@@ -3447,12 +3471,36 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestAnsiStringFail;
+procedure TTestModule.TestBaseType_AnsiStringFail;
 begin
   StartProgram(false);
   Add('var s: AnsiString');
-  Add('begin');
-  SetExpectedPasResolverError('foo',123);
+  SetExpectedPasResolverError('identifier not found "AnsiString"',nIdentifierNotFound);
+  ConvertProgram;
+end;
+
+procedure TTestModule.TestBaseType_UnicodeStringFail;
+begin
+  StartProgram(false);
+  Add('var s: UnicodeString');
+  SetExpectedPasResolverError('identifier not found "UnicodeString"',nIdentifierNotFound);
+  ConvertProgram;
+end;
+
+procedure TTestModule.TestBaseType_ShortStringFail;
+begin
+  StartProgram(false);
+  Add('var s: ShortString');
+  SetExpectedPasResolverError('identifier not found "ShortString"',nIdentifierNotFound);
+  ConvertProgram;
+end;
+
+procedure TTestModule.TestBaseType_RawByteStringFail;
+begin
+  StartProgram(false);
+  Add('var s: RawByteString');
+  SetExpectedPasResolverError('identifier not found "RawByteString"',nIdentifierNotFound);
+  ConvertProgram;
 end;
 
 procedure TTestModule.TestProcTwoArgs;
@@ -4427,6 +4475,78 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestArray_Concat;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  integer = longint;');
+  Add('  TFlag = (big,small);');
+  Add('  TFlags = set of TFlag;');
+  Add('  TRec = record');
+  Add('    i: integer;');
+  Add('  end;');
+  Add('  TArrInt = array of integer;');
+  Add('  TArrRec = array of TRec;');
+  Add('  TArrSet = array of TFlags;');
+  Add('  TArrJSValue = array of jsvalue;');
+  Add('var');
+  Add('  ArrInt: tarrint;');
+  Add('  ArrRec: tarrrec;');
+  Add('  ArrSet: tarrset;');
+  Add('  ArrJSValue: tarrjsvalue;');
+  Add('begin');
+  Add('  arrint:=concat(arrint);');
+  Add('  arrint:=concat(arrint,arrint);');
+  Add('  arrint:=concat(arrint,arrint,arrint);');
+  Add('  arrrec:=concat(arrrec);');
+  Add('  arrrec:=concat(arrrec,arrrec);');
+  Add('  arrrec:=concat(arrrec,arrrec,arrrec);');
+  Add('  arrset:=concat(arrset);');
+  Add('  arrset:=concat(arrset,arrset);');
+  Add('  arrset:=concat(arrset,arrset,arrset);');
+  Add('  arrjsvalue:=concat(arrjsvalue);');
+  Add('  arrjsvalue:=concat(arrjsvalue,arrjsvalue);');
+  Add('  arrjsvalue:=concat(arrjsvalue,arrjsvalue,arrjsvalue);');
+  ConvertProgram;
+  CheckSource('TestRecord_Var',
+    LinesToStr([ // statements
+    'this.TFlag = {',
+    '  "0": "big",',
+    '  big: 0,',
+    '  "1": "small",',
+    '  small: 1',
+    '};',
+    'this.TRec = function (s) {',
+    '  if (s) {',
+    '    this.i = s.i;',
+    '  } else {',
+    '    this.i = 0;',
+    '  };',
+    '  this.$equal = function (b) {',
+    '    return this.i == b.i;',
+    '  };',
+    '};',
+    'this.ArrInt = [];',
+    'this.ArrRec = [];',
+    'this.ArrSet = [];',
+    'this.ArrJSValue = [];',
+    '']),
+    LinesToStr([ // this.$main
+    'this.ArrInt = this.ArrInt;',
+    'this.ArrInt = this.ArrInt.concat(this.ArrInt);',
+    'this.ArrInt = this.ArrInt.concat(this.ArrInt,this.ArrInt);',
+    'this.ArrRec = this.ArrRec;',
+    'this.ArrRec = rtl.arrayConcat(this.TRec, this.ArrRec);',
+    'this.ArrRec = rtl.arrayConcat(this.TRec, this.ArrRec, this.ArrRec);',
+    'this.ArrSet = this.ArrSet;',
+    'this.ArrSet = rtl.arrayConcat("refSet", this.ArrSet);',
+    'this.ArrSet = rtl.arrayConcat("refSet", this.ArrSet, this.ArrSet);',
+    'this.ArrJSValue = this.ArrJSValue;',
+    'this.ArrJSValue = this.ArrJSValue.concat(this.ArrJSValue);',
+    'this.ArrJSValue = this.ArrJSValue.concat(this.ArrJSValue, this.ArrJSValue);',
+    '']));
+end;
+
 procedure TTestModule.TestRecord_Var;
 begin
   StartProgram(false);
@@ -7042,13 +7162,13 @@ begin
   Add('  TObject = class');
   Add('    class var FA: longint;');
   Add('    class function GetA: longint;');
-  Add('    class procedure SetA(Value: longint): longint;');
+  Add('    class procedure SetA(Value: longint);');
   Add('    class property pA: longint read fa write fa;');
   Add('    class property pB: longint read geta write seta;');
   Add('  end;');
   Add('  TObjectClass = class of tobject;');
   Add('class function tobject.geta: longint; begin end;');
-  Add('class procedure tobject.seta(value: longint): longint; begin end;');
+  Add('class procedure tobject.seta(value: longint); begin end;');
   Add('var');
   Add('  b: boolean;');
   Add('  Obj: tobject;');
@@ -8990,6 +9110,94 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestJSValue_Equal;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  integer = longint;');
+  Add('  TYesNo = boolean;');
+  Add('  TFloat = double;');
+  Add('  TCaption = string;');
+  Add('  TChar = char;');
+  Add('  TMulti = JSValue;');
+  Add('var');
+  Add('  v: jsvalue;');
+  Add('  i: integer;');
+  Add('  s: TCaption;');
+  Add('  b: TYesNo;');
+  Add('  d: TFloat;');
+  Add('  c: char;');
+  Add('  m: TMulti;');
+  Add('begin');
+  Add('  b:=v=v;');
+  Add('  b:=v<>v;');
+  Add('  b:=v=1;');
+  Add('  b:=v<>1;');
+  Add('  b:=2=v;');
+  Add('  b:=2<>v;');
+  Add('  b:=v=i;');
+  Add('  b:=i=v;');
+  Add('  b:=v=nil;');
+  Add('  b:=nil=v;');
+  Add('  b:=v=false;');
+  Add('  b:=true=v;');
+  Add('  b:=v=b;');
+  Add('  b:=b=v;');
+  Add('  b:=v=s;');
+  Add('  b:=s=v;');
+  Add('  b:=v=''foo'';');
+  Add('  b:=''''=v;');
+  Add('  b:=v=d;');
+  Add('  b:=d=v;');
+  Add('  b:=v=3.4;');
+  Add('  b:=5.6=v;');
+  Add('  b:=v=c;');
+  Add('  b:=c=v;');
+  Add('  b:=m=m;');
+  Add('  b:=v=m;');
+  Add('  b:=m=v;');
+  ConvertProgram;
+  CheckSource('TestJSValue_Equal',
+    LinesToStr([ // statements
+    'this.v = undefined;',
+    'this.i = 0;',
+    'this.s = "";',
+    'this.b = false;',
+    'this.d = 0.0;',
+    'this.c = "";',
+    'this.m = undefined;',
+    '']),
+    LinesToStr([ // this.$main
+    'this.b = this.v == this.v;',
+    'this.b = this.v != this.v;',
+    'this.b = this.v == 1;',
+    'this.b = this.v != 1;',
+    'this.b = 2 == this.v;',
+    'this.b = 2 != this.v;',
+    'this.b = this.v == this.i;',
+    'this.b = this.i == this.v;',
+    'this.b = this.v == null;',
+    'this.b = null == this.v;',
+    'this.b = this.v == false;',
+    'this.b = true == this.v;',
+    'this.b = this.v == this.b;',
+    'this.b = this.b == this.v;',
+    'this.b = this.v == this.s;',
+    'this.b = this.s == this.v;',
+    'this.b = this.v == "foo";',
+    'this.b = "" == this.v;',
+    'this.b = this.v == this.d;',
+    'this.b = this.d == this.v;',
+    'this.b = this.v == 3.4;',
+    'this.b = 5.6 == this.v;',
+    'this.b = this.v == this.c;',
+    'this.b = this.c == this.v;',
+    'this.b = this.m == this.m;',
+    'this.b = this.v == this.m;',
+    'this.b = this.m == this.v;',
+    '']));
+end;
+
 procedure TTestModule.TestJSValue_Enum;
 begin
   StartProgram(false);