pastojs: range check char:=, char parameter

git-svn-id: trunk@38831 -

packages/pastojs/src/fppas2js.pp

@@ -281,8 +281,9 @@ Works:
   - type cast to class-type and class-of-type, rtl.asExt, EInvalidCast
 - Range checks:
   - compile time: warnings to errors
-  - assign int:=, int+=, enum:=, enum+=, intrange:=, intrange+=, enumrange:=, enumrange+=
-  - procedure argument int, enum, intrange, enumrange
+  - assign int:=, int+=, enum:=, enum+=, intrange:=, intrange+=,
+      enumrange:=, enumrange+=, char:=, char+=
+  - procedure argument int, enum, intrange, enumrange, char
 - Interfaces:
   - autogenerate GUID
   - method resolution
@@ -341,7 +342,6 @@ ToDos:
   v:=a[0]  gives Local variable "a" is assigned but never used
 - setlength(dynarray)  modeswitch to create a copy
 - range checks:
-  - char:=
   - proc(c: char)
   - string[index]
   - array[index,...]
@@ -533,6 +533,7 @@ type
     pbifnProcType_Equal,
     pbifnProgramMain,
     pbifnRangeCheckInt,
+    pbifnRangeCheckChar,
     pbifnRecordEqual,
     pbifnRTTIAddField, // typeinfos of tkclass and tkrecord have addField
     pbifnRTTIAddFields, // typeinfos of tkclass and tkrecord have addFields
@@ -670,7 +671,8 @@ const
     'createCallback', // rtl.createCallback
     'eqCallback', // rtl.eqCallback
     '$main',
-    'rc',
+    'rc',  // rtl.rc
+    'rcc', // rtl.rcc
     '$equal',
     'addField',
     'addFields',
@@ -7342,6 +7344,7 @@ var
   ParamTypeEl, TypeEl: TPasType;
   aResolver: TPas2JSResolver;
   NeedIntfRef: Boolean;
+  DestRange, SrcRange: TResEvalValue;
 begin
   Result:=nil;
   if El.Kind<>pekFuncParams then
@@ -7431,6 +7434,7 @@ begin
         or (C=TPasClassOfType)
         or (C=TPasRecordType)
         or (C=TPasEnumType)
+        or (C=TPasRangeType)
         or (C=TPasArrayType) then
       begin
       // typecast
@@ -7441,7 +7445,45 @@ begin
 
       Result:=ConvertElement(Param,AContext);
 
-      if C=TPasClassType then
+      if C=TPasRangeType then
+        begin
+        DestRange:=aResolver.EvalTypeRange(TPasRangeType(Decl),[refConst]);
+        SrcRange:=nil;
+        try
+          if DestRange=nil then
+            RaiseNotSupported(El,AContext,20180424124708);
+          SrcRange:=aResolver.EvalTypeRange(ParamResolved.TypeEl,[]);
+          if SrcRange=nil then
+            RaiseNotSupported(El,AContext,20180424125331);
+          case DestRange.Kind of
+          revkRangeInt:
+            case TResEvalRangeInt(DestRange).ElKind of
+            revskEnum, revskInt:
+              // type cast to integer-range
+              case SrcRange.Kind of
+              revkRangeInt:
+                case TResEvalRangeInt(SrcRange).ElKind of
+                  revskEnum, revskInt:
+                    ; // ToDo: higher precision to lower precision -> modulo
+                else
+                  RaiseNotSupported(El,AContext,20180424130705);
+                end;
+              revkRangeUInt: ;
+              else
+                RaiseNotSupported(El,AContext,20180424125608);
+              end;
+            else
+              RaiseNotSupported(El,AContext,20180424125419);
+            end;
+          else
+            RaiseNotSupported(El,AContext,20180424124814);
+          end;
+        finally
+          ReleaseEvalValue(SrcRange);
+          ReleaseEvalValue(DestRange);
+        end;
+        end
+      else if C=TPasClassType then
         begin
         if ParamTypeEl is TPasClassType then
           case TPasClassType(Decl).ObjKind of
@@ -7548,6 +7590,7 @@ begin
       begin
       aResolver.ComputeElement(Decl,DeclResolved,[rcType]);
       if DeclResolved.TypeEl is TPasProcedureType then
+        // e.g. OnClick()
         TargetProcType:=TPasProcedureType(DeclResolved.TypeEl)
       else
         RaiseNotSupported(El,AContext,20170217115244);
@@ -11238,13 +11281,14 @@ var
     BodyJS.A:=FirstSt;
   end;
 
-  procedure AddRangeCheckInt(Arg: TPasArgument; MinVal, MaxVal: MaxPrecInt);
+  procedure AddRangeCheck(Arg: TPasArgument; MinVal, MaxVal: MaxPrecInt;
+    RTLFunc: TPas2JSBuiltInName);
   var
     Call: TJSCallExpression;
   begin
     // use Arg as PosEl, so that user knows which Arg is out of range
     Call:=CreateCallExpression(Arg);
-    Call.Expr:=CreatePrimitiveDotExpr(FBuiltInNames[pbivnRTL]+'.'+FBuiltInNames[pbifnRangeCheckInt],El);
+    Call.Expr:=CreatePrimitiveDotExpr(FBuiltInNames[pbivnRTL]+'.'+FBuiltInNames[RTLFunc],El);
     AddBodyStatement(Call,Arg);
     Call.AddArg(CreateArgumentAccess(Arg,AContext,Arg));
     Call.AddArg(CreateLiteralNumber(Arg,MinVal));
@@ -11263,13 +11307,15 @@ var
       revkRangeInt:
         case TResEvalRangeInt(Value).ElKind of
           revskEnum, revskInt:
-            AddRangeCheckInt(Arg,TResEvalRangeInt(Value).RangeStart,
-              TResEvalRangeInt(Value).RangeEnd);
-          revskChar: ; // ToDo
+            AddRangeCheck(Arg,TResEvalRangeInt(Value).RangeStart,
+              TResEvalRangeInt(Value).RangeEnd,pbifnRangeCheckInt);
+          revskChar:
+            AddRangeCheck(Arg,TResEvalRangeInt(Value).RangeStart,
+              TResEvalRangeInt(Value).RangeEnd,pbifnRangeCheckChar);
         end;
       revkRangeUInt:
-        AddRangeCheckInt(Arg,TResEvalRangeUInt(Value).RangeStart,
-          TResEvalRangeUInt(Value).RangeEnd);
+        AddRangeCheck(Arg,TResEvalRangeUInt(Value).RangeStart,
+          TResEvalRangeUInt(Value).RangeEnd,pbifnRangeCheckInt);
       else
         RaiseNotSupported(Arg,AContext,20180424112010,'range checking '+Value.AsDebugString);
       end;
@@ -11400,11 +11446,13 @@ begin
               begin
               if not aResolver.GetIntegerRange(ArgResolved.BaseType,MinVal,MaxVal) then
                 RaiseNotSupported(Arg,AContext,20180119192608);
-              AddRangeCheckInt(Arg,MinVal,MaxVal);
+              AddRangeCheck(Arg,MinVal,MaxVal,pbifnRangeCheckInt);
               end
             else if ArgTypeEl.ClassType=TPasRangeType then
               AddRangeCheckType(Arg,ArgTypeEl);
             end
+          else if ArgResolved.BaseType in btAllJSChars then
+            AddRangeCheckType(Arg,ArgTypeEl)
           else if ArgResolved.BaseType=btContext then
             begin
             if ArgTypeEl.ClassType=TPasEnumType then
@@ -13676,13 +13724,13 @@ function TPasToJSConverter.ConvertAssignStatement(El: TPasImplAssign;
         +GetResolverResultDbg(AssignContext.RightResolved));
   end;
 
-  function CreateRangeCheckInt(AssignSt: TJSElement;
-    MinVal, MaxVal: MaxPrecInt): TJSElement;
+  function CreateRangeCheck(AssignSt: TJSElement;
+    MinVal, MaxVal: MaxPrecInt; RTLFunc: TPas2JSBuiltInName): TJSElement;
   var
     Call: TJSCallExpression;
   begin
     Call:=CreateCallExpression(El);
-    Call.Expr:=CreatePrimitiveDotExpr(FBuiltInNames[pbivnRTL]+'.'+FBuiltInNames[pbifnRangeCheckInt],El);
+    Call.Expr:=CreatePrimitiveDotExpr(FBuiltInNames[pbivnRTL]+'.'+FBuiltInNames[RTLFunc],El);
     if AssignSt.ClassType=TJSSimpleAssignStatement then
       begin
       // LHS:=rtl.rc(RHS,min,max)    check before assign
@@ -13713,13 +13761,15 @@ function TPasToJSConverter.ConvertAssignStatement(El: TPasImplAssign;
       revkRangeInt:
         case TResEvalRangeInt(Value).ElKind of
           revskEnum, revskInt:
-            Result:=CreateRangeCheckInt(AssignSt,TResEvalRangeInt(Value).RangeStart,
-              TResEvalRangeInt(Value).RangeEnd);
-          revskChar: ; // ToDo
+            Result:=CreateRangeCheck(AssignSt,TResEvalRangeInt(Value).RangeStart,
+              TResEvalRangeInt(Value).RangeEnd,pbifnRangeCheckInt);
+          revskChar:
+            Result:=CreateRangeCheck(AssignSt,TResEvalRangeInt(Value).RangeStart,
+              TResEvalRangeInt(Value).RangeEnd,pbifnRangeCheckChar);
         end;
       revkRangeUInt:
-        Result:=CreateRangeCheckInt(AssignSt,TResEvalRangeUInt(Value).RangeStart,
-          TResEvalRangeUInt(Value).RangeEnd);
+        Result:=CreateRangeCheck(AssignSt,TResEvalRangeUInt(Value).RangeStart,
+          TResEvalRangeUInt(Value).RangeEnd,pbifnRangeCheckInt);
       else
         RaiseNotSupported(El,AContext,20180424111037,'range checking '+Value.AsDebugString);
       end;
@@ -13997,11 +14047,13 @@ begin
             begin
             if not aResolver.GetIntegerRange(AssignContext.LeftResolved.BaseType,MinVal,MaxVal) then
               RaiseNotSupported(El.left,AContext,20180119154120);
-            Result:=CreateRangeCheckInt(Result,MinVal,MaxVal);
+            Result:=CreateRangeCheck(Result,MinVal,MaxVal,pbifnRangeCheckInt);
             end
           else if LeftTypeEl.ClassType=TPasRangeType then
             Result:=CreateRangeCheckType(Result,LeftTypeEl);
           end
+        else if AssignContext.LeftResolved.BaseType in btAllJSChars then
+          Result:=CreateRangeCheckType(Result,LeftTypeEl)
         else if AssignContext.LeftResolved.BaseType=btContext then
           begin
           if LeftTypeEl.ClassType=TPasEnumType then

packages/pastojs/tests/tcmodules.pas

@@ -635,6 +635,7 @@ type
     procedure TestRangeChecks_AssignIntRange;
     procedure TestRangeChecks_AssignEnum;
     procedure TestRangeChecks_AssignEnumRange;
+    procedure TestRangeChecks_AssignChar;
   end;
 
 function LinesToStr(Args: array of const): string;
@@ -19878,13 +19879,13 @@ begin
   'procedure DoIt(p: TEnum);',
   'begin',
   '  e:=p;',
-  '  p:=red;',
+  '  p:=TEnum(0);',
   '  p:=succ(e);',
   'end;',
   '{$R-}',
   'begin',
   '  DoIt(e);',
-  '  e:=green;',
+  '  e:=TEnum(1);',
   '  e:=pred(e);',
   '{$R+}',
   '']);
@@ -19901,13 +19902,13 @@ begin
     'this.DoIt = function (p) {',
     '  rtl.rc(p, 0, 1);',
     '  $mod.e = rtl.rc(p, 0, 1);',
-    '  p = rtl.rc($mod.TEnum.red, 0, 1);',
+    '  p = 0;',
     '  p = rtl.rc($mod.e + 1, 0, 1);',
     '};',
     '']),
     LinesToStr([ // $mod.$main
     '$mod.DoIt($mod.e);',
-    '$mod.e = rtl.rc($mod.TEnum.green, 0, 1);',
+    '$mod.e = 1;',
     '$mod.e = rtl.rc($mod.e-1, 0, 1);',
     '']));
 end;
@@ -19925,13 +19926,13 @@ begin
   'procedure DoIt(p: TEnumRg);',
   'begin',
   '  e:=p;',
-  '  p:=red;',
+  '  p:=TEnumRg(0);',
   '  p:=succ(e);',
   'end;',
   '{$R-}',
   'begin',
   '  DoIt(e);',
-  '  e:=green;',
+  '  e:=TEnumRg(1);',
   '  e:=pred(e);',
   '{$R+}',
   '']);
@@ -19948,17 +19949,57 @@ begin
     'this.DoIt = function (p) {',
     '  rtl.rc(p, 0, 1);',
     '  $mod.e = rtl.rc(p, 0, 1);',
-    '  p = rtl.rc($mod.TEnum.red, 0, 1);',
+    '  p = 0;',
     '  p = rtl.rc($mod.e + 1, 0, 1);',
     '};',
     '']),
     LinesToStr([ // $mod.$main
     '$mod.DoIt($mod.e);',
-    '$mod.e = rtl.rc($mod.TEnum.green, 0, 1);',
+    '$mod.e = 1;',
     '$mod.e = rtl.rc($mod.e-1, 0, 1);',
     '']));
 end;
 
+procedure TTestModule.TestRangeChecks_AssignChar;
+begin
+  Scanner.Options:=Scanner.Options+[po_CAssignments];
+  StartProgram(false);
+  Add([
+  '{$R+}',
+  'type TLetter = char;',
+  'var',
+  '  b: TLetter = ''2'';',
+  '  w: TLetter = ''3'';',
+  'procedure DoIt(p: TLetter);',
+  'begin',
+  '  b:=w;',
+  '  b:=''1'';',
+  'end;',
+  '{$R-}',
+  'begin',
+  '  DoIt(w);',
+  '  b:=w;',
+  '  b:=''2'';',
+  '{$R+}',
+  '']);
+  ConvertProgram;
+  CheckSource('TestRangeChecks_AssignChar',
+    LinesToStr([ // statements
+    'this.b = "2";',
+    'this.w = "3";',
+    'this.DoIt = function (p) {',
+    '  rtl.rcc(p, 0, 65535);',
+    '  $mod.b = rtl.rcc($mod.w, 0, 65535);',
+    '  $mod.b = "1";',
+    '};',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.DoIt($mod.w);',
+    '$mod.b = rtl.rcc($mod.w, 0, 65535);',
+    '$mod.b = "2";',
+    '']));
+end;
+
 Initialization
   RegisterTests([TTestModule]);
 end.

utils/pas2js/dist/rtl.js

@@ -650,6 +650,15 @@ var rtl = {
     rtl.raiseE('ERangeError');
   },
 
+  rcc: function(c,minval,maxval){
+    // range check char
+    if (typeof(c)==='string') && (c.length===1)){
+      var i = c.charCodeAt(0);
+      if ((i>=minval) && (i<=maxval)) return c;
+    }
+    rtl.raiseE('ERangeError');
+  },
+
   length: function(arr){
     return (arr == null) ? 0 : arr.length;
   },