pastojs: custom ranges: char, enum, integer

git-svn-id: trunk@37575 -

packages/pastojs/src/fppas2js.pp

@@ -251,8 +251,17 @@ Works:
   - use 0b for binary literals
   - use 0o for octal literals
 - dotted unit names, namespaces
+- resourcestring
 
 ToDos:
+- enum range, int range, char range, set of enumrange, set of intrange, set of charrange
+- custom ranges
+  - enum: low(), high(), pred(), succ(), ord(), rg(int), int(rg), enum:=rg,
+    rg:=rg, rg1:=rg2, rg:=enum, =, <>, in
+    array[rg], low(array), high(array)
+- enumeration  for..in..do
+    enum, set, char, intrange, enumrange, array
+- typecast longint(highprecint) -> (value+0) & $ffffffff
 - static arrays
   - a[] of record
 - RTTI
@@ -263,8 +272,6 @@ ToDos:
 - var absolute
 - check memleaks
 - make records more lightweight
-- enumeration  for..in..do
-- resourcestring
 - pointer of record
 - nested types in class
 - asm: pas() - useful for overloads and protect an identifier from optimization
@@ -2016,13 +2023,60 @@ end;
 procedure TPas2JSResolver.FinishSetType(El: TPasSetType);
 var
   TypeEl: TPasType;
+  C: TClass;
+  RangeValue: TResEvalValue;
+  bt: TResolverBaseType;
 begin
   inherited FinishSetType(El);
   TypeEl:=ResolveAliasType(El.EnumType);
-  if TypeEl.ClassType=TPasEnumType then
-    // ok
-  else
-    RaiseMsg(20170415182320,nNotSupportedX,sNotSupportedX,['set of '+TypeEl.Name],El);
+  C:=TypeEl.ClassType;
+  if C=TPasEnumType then
+    exit
+  else if C=TPasUnresolvedSymbolRef then
+    begin
+    if TypeEl.CustomData is TResElDataBaseType then
+      begin
+      bt:=TResElDataBaseType(TypeEl.CustomData).BaseType;
+      if bt in [btBoolean,btByte,btShortInt,btSmallInt,btWord,btChar,btWideChar] then
+        exit; // ok
+      {$IFDEF VerbosePas2JS}
+      writeln('TPas2JSResolver.FinishSetType El='+GetObjName(El)+' TypeEl=',GetObjName(TypeEl),' ',bt);
+      {$ENDIF}
+      RaiseMsg(20171110150000,nNotSupportedX,sNotSupportedX,['set of '+TypeEl.Name],El);
+      end;
+    end
+  else if C=TPasRangeType then
+    begin
+    RangeValue:=Eval(TPasRangeType(TypeEl).RangeExpr,[refConst]);
+    try
+      case RangeValue.Kind of
+      revkRangeInt:
+        begin
+        if TResEvalRangeInt(RangeValue).RangeEnd-TResEvalRangeInt(RangeValue).RangeStart>$ffff then
+          begin
+          {$IFDEF VerbosePas2JS}
+          writeln('TPas2JSResolver.FinishSetType El='+GetObjName(El)+' Range='+RangeValue.AsDebugString,' ',bt);
+          {$ENDIF}
+          RaiseMsg(20171110150159,nNotSupportedX,sNotSupportedX,['set of '+TypeEl.Name],El);
+          end;
+        exit;
+        end;
+      else
+        begin
+        {$IFDEF VerbosePas2JS}
+        writeln('TPas2JSResolver.FinishSetType El='+GetObjName(El)+' Range='+RangeValue.AsDebugString);
+        {$ENDIF}
+        RaiseMsg(20171110145211,nNotSupportedX,sNotSupportedX,['set of '+TypeEl.Name],El);
+        end;
+      end;
+    finally
+      ReleaseEvalValue(RangeValue);
+    end;
+    end;
+  {$IFDEF VerbosePas2JS}
+  writeln('TPas2JSResolver.FinishSetType El='+GetObjName(El)+' TypeEl=',GetObjName(TypeEl));
+  {$ENDIF}
+  RaiseMsg(20170415182320,nNotSupportedX,sNotSupportedX,['set of '+TypeEl.Name],El);
 end;
 
 procedure TPas2JSResolver.FinishClassType(El: TPasClassType);
@@ -10521,6 +10575,9 @@ begin
   BinExp:=Nil;
   if AContext.Access<>caRead then
     RaiseInconsistency(20170213213740);
+  if not (El.LoopType in [ltNormal,ltDown]) then
+    RaiseNotSupported(El,AContext,20171110141937);
+
   // get function context
   FuncContext:=AContext;
   while (FuncContext.Parent<>nil) and (not (FuncContext is TFunctionContext)) do
@@ -10931,7 +10988,7 @@ var
   bt: TResolverBaseType;
   JSBaseType: TPas2jsBaseType;
   C: TClass;
-  ResolvedEl: TPasResolverResult;
+  Value: TResEvalValue;
 begin
   T:=PasType;
   if AContext.Resolver<>nil then
@@ -10970,20 +11027,14 @@ begin
     // a "set" without initial value
     Result:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,El))
   else if (C=TPasRangeType) and (AContext.Resolver<>nil) then
-    // a custom range without initial value
+    // a custom range without initial value -> use first value
     begin
-    AContext.Resolver.ComputeElement(PasType,ResolvedEl,[rcType]);
-    if ResolvedEl.BaseType in btAllInteger then
-      Result:=CreateLiteralNumber(El,0)
-    else if ResolvedEl.BaseType in btAllStringAndChars then
-      Result:=CreateLiteralJSString(El,'')
-    else
-      begin
-      {$IFDEF VerbosePas2JS}
-      writeln('TPasToJSConverter.CreateValInit ',GetResolverResultDbg(ResolvedEl));
-      {$ENDIF}
-      RaiseNotSupported(El,AContext,20170925203052);
-      end;
+    Value:=AContext.Resolver.Eval(TPasRangeType(T).RangeExpr.left,[refConst]);
+    try
+      Result:=ConvertConstValue(Value,AContext,El);
+    finally
+      ReleaseEvalValue(Value);
+    end;
     end
   else
     begin
@@ -11196,7 +11247,8 @@ begin
   if AContext.Resolver<>nil then
     begin
     AContext.Resolver.ComputeElement(Expr,ExprResolved,[]);
-    if ExprResolved.BaseType in btAllJSStringAndChars then
+    if (ExprResolved.BaseType in btAllJSStringAndChars)
+        or ((ExprResolved.BaseType=btRange) and (ExprResolved.SubType in btAllJSChars)) then
       begin
       // aChar -> aChar.charCodeAt()
       Call:=TJSCallExpression(CreateElement(TJSCallExpression,Expr));
@@ -11277,7 +11329,7 @@ begin
         end
       else if ExprResolved.BaseType in btAllStringAndChars then
         begin
-        US:=TJSString(AContext.Resolver.ComputeConstString(Expr,false,true));
+        US:=TJSString(UTF8Decode(AContext.Resolver.ComputeConstString(Expr,false,true)));
         for i:=1 to length(US) do
           ArrLit.Elements.AddElement.Expr:=CreateLiteralJSString(Expr,US[i]);
         end

packages/pastojs/tests/tcmodules.pas

@@ -203,6 +203,7 @@ type
 
     // numbers
     Procedure TestDouble;
+    Procedure TestIntegerRange;
 
     // strings
     Procedure TestCharConst;
@@ -220,6 +221,7 @@ type
     Procedure TestBaseType_ShortStringFail;
     Procedure TestBaseType_RawByteStringFail;
     Procedure TestTypeShortstring_Fail;
+    Procedure TestCharSet_Custom;
 
     // alias types
     Procedure TestAliasTypeRef;
@@ -271,8 +273,6 @@ type
     Procedure TestSet_Property;
     Procedure TestSet_EnumConst;
     Procedure TestSet_AnonymousEnumType;
-    Procedure TestSet_CharFail;
-    Procedure TestSet_BooleanFail;
     Procedure TestSet_ConstEnum;
     Procedure TestSet_ConstChar;
     Procedure TestSet_ConstInt;
@@ -3657,26 +3657,6 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestSet_CharFail;
-begin
-  StartProgram(false);
-  Add('type');
-  Add('  TChars = set of char;');
-  Add('begin');
-  SetExpectedPasResolverError('Not supported: set of Char',nNotSupportedX);
-  ConvertProgram;
-end;
-
-procedure TTestModule.TestSet_BooleanFail;
-begin
-  StartProgram(false);
-  Add('type');
-  Add('  TBools = set of boolean;');
-  Add('begin');
-  SetExpectedPasResolverError('Not supported: set of Boolean',nNotSupportedX);
-  ConvertProgram;
-end;
-
 procedure TTestModule.TestSet_ConstEnum;
 begin
   StartProgram(false);
@@ -4050,6 +4030,53 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestIntegerRange;
+begin
+  StartProgram(false);
+  Add([
+  'const',
+  '  MinInt = -1;',
+  '  MaxInt = +1;',
+  'type',
+  '  {#TMyInt}TMyInt = MinInt..MaxInt;',
+  '  TInt2 = 1..3;',
+  'const',
+  '  a = low(TMyInt)+High(TMyInt);',
+  '  b = low(TInt2)+High(TInt2);',
+  '  s1 = [1];',
+  '  s2 = [1,2];',
+  '  s3 = [1..3];',
+  '  s4 = [low(shortint)..high(shortint)];',
+  '  s5 = [succ(low(shortint))..pred(high(shortint))];',
+  '  s6 = 1 in s2;',
+  'var',
+  '  i: TMyInt;',
+  '  i2: TInt2;',
+  'begin',
+  '  i:=i2;',
+  '  if i=i2 then ;']);
+  ConvertProgram;
+  CheckSource('TestIntegerRange',
+    LinesToStr([
+    'this.MinInt = -1;',
+    'this.MaxInt = +1;',
+    'this.a = -1 + 1;',
+    'this.b = 1 + 3;',
+    'this.s1 = rtl.createSet(1);',
+    'this.s2 = rtl.createSet(1, 2);',
+    'this.s3 = rtl.createSet(null, 1, 3);',
+    'this.s4 = rtl.createSet(null, -128, 127);',
+    'this.s5 = rtl.createSet(null, -128 + 1, 127 - 1);',
+    'this.s6 = 1 in $mod.s2;',
+    'this.i = -1;',
+    'this.i2 = 1;',
+    '']),
+    LinesToStr([
+    '$mod.i = $mod.i2;',
+    'if ($mod.i === $mod.i2) ;',
+    '']));
+end;
+
 procedure TTestModule.TestCharConst;
 begin
   StartProgram(false);
@@ -4423,6 +4450,50 @@ begin
   ConvertProgram;
 end;
 
+procedure TTestModule.TestCharSet_Custom;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TCharRg = ''a''..''z'';',
+  '  TSetOfCharRg = set of TCharRg;',
+  '  TCharRg2 = ''m''..''p'';',
+  'const',
+  '  crg: TCharRg = ''b'';',
+  'var',
+  '  c: char;',
+  '  crg2: TCharRg2;',
+  '  s: TSetOfCharRg;',
+  'begin',
+  '  c:=crg;',
+  '  crg:=c;',
+  '  crg2:=crg;',
+  '  if c=crg then ;',
+  '  if crg=c then ;',
+  '  if crg=crg2 then ;',
+  '  if c in s then ;',
+  '  if crg2 in s then ;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestCharSet_Custom',
+    LinesToStr([ // statements
+    'this.crg = "b";',
+    'this.c = "";',
+    'this.crg2 = "m";',
+    'this.s = {};',
+    '']),
+    LinesToStr([ // this.$main
+    '$mod.c = $mod.crg;',
+    '$mod.crg = $mod.c;',
+    '$mod.crg2 = $mod.crg;',
+    'if ($mod.c === $mod.crg) ;',
+    'if ($mod.crg === $mod.c) ;',
+    'if ($mod.crg === $mod.crg2) ;',
+    'if ($mod.c.charCodeAt() in $mod.s) ;',
+    'if ($mod.crg2.charCodeAt() in $mod.s) ;',
+    '']));
+end;
+
 procedure TTestModule.TestProcTwoArgs;
 begin
   StartProgram(false);
@@ -5207,6 +5278,7 @@ begin
   Add('  Arr2: TChars2;');
   Add('  Arr3: array[2..4] of char = (''p'',''a'',''s'');');
   Add('  Arr4: array[11..13] of char = ''pas'';');
+  Add('  Arr5: array[21..22] of char = ''äö'';');
   Add('  c: char;');
   Add('  b: boolean;');
   Add('begin');
@@ -5229,6 +5301,7 @@ begin
     'this.Arr2 = rtl.arraySetLength(null, "", 26);',
     'this.Arr3 = ["p", "a", "s"];',
     'this.Arr4 = ["p", "a", "s"];',
+    'this.Arr5 = ["ä", "ö"];',
     'this.c = "";',
     'this.b = false;',
     '']),
@@ -13977,7 +14050,7 @@ begin
     'this.h = 1;',
     'rtl.createClass($mod, "TObject", null, function () {',
     '  this.$init = function () {',
-    '    this.FV = 0;',
+    '    this.FV = -1;',
     '  };',
     '  this.$final = function () {',
     '  };',