* Patch from Mattias Gaertner

- allow only String, no other string types
  - assigned(array)
  - tpasargument proc type

git-svn-id: trunk@35683 -

packages/pastojs/src/fppas2js.pp

@@ -48,6 +48,7 @@ Works:
   - literals
   - setlength(s,newlen) -> s.length == newlen
   - read and write char aString[]
+  - allow only String, no ShortString, AnsiString, UnicodeString,...
 - for loop
   - if loopvar is used afterwards append  if($loopend>i)i--;
 - repeat..until
@@ -101,10 +102,9 @@ Works:
 - dynamic arrays
   - init as "arr = []"  arrays must never be null
   - SetLength(arr,len) becomes  arr = SetLength(arr,len,defaultvalue)
-  - length(arr)
+  - length(), low(), high(), assigned()
   - assign nil -> []  arrays must never be null
   - read, write element arr[index]
-  - low(), high()
   - multi dimensional [index1,index2] -> [index1][index2]
   - array of record
   - equal, unequal nil -> array.length == 0
@@ -196,7 +196,31 @@ Works:
   - parameter, result type, assign from/to untyped
 
 ToDos:
+- if jsvalue<>nil  jsvalue=nil
+- function copy(array): array
+- function copy(array,start): array
+- function copy(array,start,count): array
+- proc insert(const 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
+- allow type casting array to external class 'Array'
+- document "overload" modifier
+- test param const R: TRect  r.Left:=3 fails
+- FuncName:= (instead of Result:=)
+- ord(s[i]) -> s.charCodeAt(i)
+- $modeswitch -> define <modeswitch>
+- $modeswitch- -> turn off
 - add rtl functions IsString, IsInteger, IsBoolean, IsDouble, IsTObject, IsClass, IsEnum, IsUndefined
+- integer range
+- @@ compare method in
+- dotted unit names, namespaces
+- type alias type
+- RTTI
+- enumeration  for..in..do
+- pointer of record
+- nested types in class
 
 Not in Version 1.0:
 - write, writeln
@@ -204,7 +228,7 @@ Not in Version 1.0:
 - arrays
   - static array: non 0 start index, length
   - array of static array: setlength
-  - array range char, char rangge, integer range, enum range
+  - array range char, char range, integer range, enum range
   - array of const
 - sets
   - set of char, boolean, integer range, char range, enum range
@@ -227,16 +251,12 @@ Not in Version 1.0:
   -O1 no function Result var when assigned only once
   - SetLength(scope.a,l) -> read scope only once, same for
     Include, Exclude, Inc, Dec
-- dotted unit names
-- pointer of record
 - objects, interfaces, advanced records
 - class helpers, type helpers, record helpers,
-- nested types in class
 - generics
 - operator overloading
-- enumeration  for..in..do
 - inline
-- type alias type
+- anonymous functions
 
 Compile flags for debugging: -d<x>
    VerbosePas2JS
@@ -632,6 +652,9 @@ type
   public
     constructor Create;
     destructor Destroy; override;
+    procedure AddObjFPCBuiltInIdentifiers(
+      const TheBaseTypes: TResolveBaseTypes=btAllStandardTypes;
+      const TheBaseProcs: TResolverBuiltInProcs=bfAllStandardProcs); override;
     // compute literals and constants
     Function ExtractPasStringLiteral(El: TPasElement; const S: String): TJSString; virtual;
     Function ComputeConst(Expr: TPasExpr; StoreCustomData: boolean): TJSValue; virtual;
@@ -1002,7 +1025,7 @@ type
   end;
 
 var
-  JSValueTypeCaptions: array[TJSType] of string = (
+  JSTypeCaptions: array[TJSType] of string = (
     'undefined',
     'null',
     'boolean',
@@ -1861,6 +1884,13 @@ begin
   inherited Destroy;
 end;
 
+procedure TPas2JSResolver.AddObjFPCBuiltInIdentifiers(
+  const TheBaseTypes: TResolveBaseTypes;
+  const TheBaseProcs: TResolverBuiltInProcs);
+begin
+  inherited AddObjFPCBuiltInIdentifiers(TheBaseTypes-btAllStrings+[btString], TheBaseProcs);
+end;
+
 function TPas2JSResolver.ExtractPasStringLiteral(El: TPasElement;
   const S: String): TJSString;
 { Extracts the value from a Pascal string literal
@@ -2040,7 +2070,7 @@ begin
   if V.ValueType<>jsbase.jstString then
     RaiseNotYetImplemented(20170320220728,Expr,'expected string constant');
   if V.ValueType<>jstString then
-    RaiseMsg(20170211221121,nExpectedXButFoundY,sExpectedXButFoundY,['string literal',JSValueTypeCaptions[V.ValueType]],Expr);
+    RaiseMsg(20170211221121,nExpectedXButFoundY,sExpectedXButFoundY,['string literal',JSTypeCaptions[V.ValueType]],Expr);
   if NotEmpty and (V.AsString='') then
     RaiseMsg(20170321085318,nExpectedXButFoundY,sExpectedXButFoundY,['string literal','empty'],Expr);
   Result:=String(V.AsString);
@@ -4030,6 +4060,14 @@ begin
       else
         RaiseNotSupported(El,AContext,20170217115244);
       end
+    else if (Decl.ClassType=TPasArgument) then
+      begin
+      AContext.Resolver.ComputeElement(Decl,DeclResolved,[rcType]);
+      if DeclResolved.TypeEl is TPasProcedureType then
+        TargetProcType:=TPasProcedureType(DeclResolved.TypeEl)
+      else
+        RaiseNotSupported(El,AContext,20170328224020);
+      end
     else if (Decl.ClassType=TPasProcedureType)
         or (Decl.ClassType=TPasFunctionType) then
       begin
@@ -4712,24 +4750,49 @@ end;
 
 function TPasToJSConverter.ConvertBuiltInAssigned(El: TParamsExpr;
   AContext: TConvertContext): TJSElement;
-// convert Assigned(value)  ->  value!=null
 var
   NE: TJSEqualityExpressionNE;
   Param: TPasExpr;
+  ParamResolved: TPasResolverResult;
+  C: TClass;
+  GT: TJSRelationalExpressionGT;
 begin
   Result:=nil;
   if AContext.Resolver=nil then
     RaiseInconsistency(20170210105235);
   Param:=El.Params[0];
-  NE:=TJSEqualityExpressionNE(CreateElement(TJSEqualityExpressionNE,El));
-  try
-    NE.A:=ConvertElement(Param,AContext);
-    NE.B:=CreateLiteralNull(El);
-    Result:=NE;
-  finally
-    if Result=nil then
-      NE.Free;
-  end;
+  AContext.Resolver.ComputeElement(Param,ParamResolved,[rcNoImplicitProcType]);
+  {$IFDEF VerbosePas2JS}
+  writeln('TPasToJSConverter.ConvertBuiltInAssigned ParamResolved=',GetResolverResultDesc(ParamResolved));
+  {$ENDIF}
+  if ParamResolved.BaseType=btContext then
+    begin
+    C:=ParamResolved.TypeEl.ClassType;
+    if (C=TPasClassType)
+        or (C=TPasClassOfType)
+        or C.InheritsFrom(TPasProcedureType) then
+      begin
+      // convert Assigned(value)  ->  value!=null
+      Result:=ConvertElement(Param,AContext);
+      // Note: convert Param first, it may raise an exception
+      NE:=TJSEqualityExpressionNE(CreateElement(TJSEqualityExpressionNE,El));
+      NE.A:=Result;
+      NE.B:=CreateLiteralNull(El);
+      Result:=NE;
+      end
+    else if C=TPasArrayType then
+      begin
+      // convert Assigned(value)  ->  value.length>0
+      Result:=ConvertElement(Param,AContext);
+      // Note: convert Param first, it may raise an exception
+      GT:=TJSRelationalExpressionGT(CreateElement(TJSRelationalExpressionGT,El));
+      GT.A:=CreateDotExpression(El,Result,CreateBuiltInIdentifierExpr('length'));
+      GT.B:=CreateLiteralNumber(El,0);
+      Result:=GT;
+      end
+    else
+      RaiseNotSupported(El,AContext,20170328124606);
+    end;
 end;
 
 function TPasToJSConverter.ConvertBuiltInChr(El: TParamsExpr;

packages/pastojs/tests/tcmodules.pas

@@ -184,6 +184,7 @@ type
     Procedure TestString_SetLength;
     Procedure TestString_CharAt;
     Procedure TestStr;
+    Procedure TestAnsiStringFail;
 
     // alias types
     Procedure TestAliasTypeRef;
@@ -374,6 +375,7 @@ type
     Procedure TestJSValue_ArrayOfJSValue;
     Procedure TestJSValue_Params;
     Procedure TestJSValue_UntypedParam;
+    Procedure TestJSValue_FuncType;
   end;
 
 function LinesToStr(Args: array of const): string;
@@ -3445,6 +3447,14 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestAnsiStringFail;
+begin
+  StartProgram(false);
+  Add('var s: AnsiString');
+  Add('begin');
+  SetExpectedPasResolverError('foo',123);
+end;
+
 procedure TTestModule.TestProcTwoArgs;
 begin
   StartProgram(false);
@@ -3984,6 +3994,7 @@ begin
   Add('var');
   Add('  Arr: TArrayInt;');
   Add('  i: longint;');
+  Add('  b: boolean;');
   Add('begin');
   Add('  SetLength(arr,3);');
   Add('  arr[0]:=4;');
@@ -3992,11 +4003,13 @@ begin
   Add('  arr[arr[i]]:=arr[6];');
   Add('  i:=low(arr);');
   Add('  i:=high(arr);');
+  Add('  b:=Assigned(arr);');
   ConvertProgram;
   CheckSource('TestArray_Dynamic',
     LinesToStr([ // statements
     'this.Arr = [];',
-    'this.i = 0;'
+    'this.i = 0;',
+    'this.b = false;'
     ]),
     LinesToStr([ // this.$main
     'this.Arr = rtl.arraySetLength(this.Arr,3,0);',
@@ -4006,6 +4019,7 @@ begin
     'this.Arr[this.Arr[this.i]] = this.Arr[6];',
     'this.i = 0;',
     'this.i = this.Arr.length - 1;',
+    'this.b = this.Arr.length > 0;',
     '']));
 end;
 
@@ -9264,6 +9278,45 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestJSValue_FuncType;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  integer = longint;');
+  Add('  TJSValueArray = array of JSValue;');
+  Add('  TListSortCompare = function(Item1, Item2: JSValue): Integer;');
+  Add('procedure Sort(P: JSValue; aList: TJSValueArray; const Compare: TListSortCompare);');
+  Add('begin');
+  Add('  while Compare(P,aList[0])>0 do ;');
+  Add('end;');
+  Add('var');
+  Add('  Compare: TListSortCompare;');
+  Add('  V: JSValue;');
+  Add('  i: integer;');
+  Add('begin');
+  Add('  if Compare(V,V)>0 then ;');
+  Add('  if Compare(i,i)>1 then ;');
+  Add('  if Compare(nil,false)>2 then ;');
+  Add('  if Compare(1,true)>3 then ;');
+  ConvertProgram;
+  CheckSource('TestJSValue_UntypedParam',
+    LinesToStr([ // statements
+    'this.Sort = function (P, aList, Compare) {',
+    '  while (Compare(P, aList[0]) > 0) {',
+    '  };',
+    '};',
+    'this.Compare = null;',
+    'this.V = undefined;',
+    'this.i = 0;',
+    '']),
+    LinesToStr([ // this.$main
+    'if (this.Compare(this.V, this.V) > 0) ;',
+    'if (this.Compare(this.i, this.i) > 1) ;',
+    'if (this.Compare(null, false) > 2) ;',
+    'if (this.Compare(1, true) > 3) ;',
+    '']));
+end;
+
 Initialization
   RegisterTests([TTestModule]);
 end.