pastojs: implemented verify method call validity

git-svn-id: trunk@37997 -

packages/pastojs/src/fppas2js.pp

@@ -407,6 +407,7 @@ type
     pbifnArray_SetLength,
     pbifnAs,
     pbifnAsExt,
+    pbifnCheckMethodCall,
     pbifnClassInstanceFree,
     pbifnClassInstanceNew,
     pbifnCreateClass,
@@ -515,6 +516,7 @@ const
     'arraySetLength', // rtl.arraySetLength
     'as', // rtl.as
     'asExt', // rtl.asExt
+    'checkMethodCall',
     '$destroy',
     '$create',
     'createClass', // rtl.createClass
@@ -843,11 +845,14 @@ const
 
   msAllPas2jsBoolSwitches = [
     bsAssertions,
+    bsRangeChecks,
+    bsOverflowChecks,
     bsHints,
     bsNotes,
     bsWarnings,
     bsMacro,
-    bsScopedEnums
+    bsScopedEnums,
+    bsMethodCallChecks
     ];
 
   btAllJSBaseTypes = [
@@ -1011,6 +1016,7 @@ type
     Access: TCtxAccess;
     AccessContext: TConvertContext;
     TmpVarCount: integer;
+    ScannerBoolSwitches: TBoolSwitches;
     constructor Create(PasEl: TPasElement; JSEl: TJSElement; aParent: TConvertContext); virtual;
     function GetRootModule: TPasModule;
     function GetFunctionContext: TFunctionContext;
@@ -3551,6 +3557,7 @@ begin
     Resolver:=Parent.Resolver;
     Access:=aParent.Access;
     AccessContext:=aParent.AccessContext;
+    ScannerBoolSwitches:=aParent.ScannerBoolSwitches;
     end;
 end;
 
@@ -7591,9 +7598,8 @@ function TPasToJSConverter.ConvertBuiltIn_Assert(El: TParamsExpr;
   AContext: TConvertContext): TJSElement;
 // throw pas.SysUtils.EAssertionFailed.$create("Create");
 // throw pas.SysUtils.EAssertionFailed.$create("Create$1",["text"]);
+// throw "text"
 var
-  CtxEl: TPasElement;
-  ProcScope: TPasProcedureScope;
   IfSt: TJSIfStatement;
   ThrowSt: TJSThrowStatement;
   ModScope: TPasModuleScope;
@@ -7603,32 +7609,12 @@ var
   Call: TJSCallExpression;
   FunName: String;
   PosEl: TPasExpr;
-  Enabled: Boolean;
 begin
   Result:=nil;
 
   // check if assertions are enabled
-  Enabled:=false;
-  CtxEl:=El;
-  while CtxEl<>nil do
-    begin
-    if CtxEl is TPasProcedure then
-      begin
-      ProcScope:=CtxEl.CustomData as TPasProcedureScope;
-      if not (ppsfAssertions in ProcScope.Flags) then exit;
-      Enabled:=true;
-      break;
-      end
-    else if CtxEl is TPasModule then
-      begin
-      ModScope:=CtxEl.CustomData as TPasModuleScope;
-      if not (pmsfAssertions in ModScope.Flags) then exit;
-      Enabled:=true;
-      break;
-      end;
-    CtxEl:=CtxEl.Parent;
-    end;
-  if not Enabled then exit;
+  if not (bsAssertions in AContext.ScannerBoolSwitches) then
+    exit;
 
   Ref:=nil;
   IfSt:=TJSIfStatement(CreateElement(TJSIfStatement,El));
@@ -9130,6 +9116,9 @@ Var
   SelfSt: TJSVariableStatement;
   ImplProc: TPasProcedure;
   BodyPas: TProcedureBody;
+  PosEl: TPasElement;
+  Call: TJSCallExpression;
+  ClassPath: String;
 begin
   Result:=nil;
 
@@ -9173,25 +9162,41 @@ begin
     FD.Params.Add(TransformVariableName(Arg,AContext));
     end;
 
-  if ImplProc.Body<>nil then
+  BodyPas:=ImplProc.Body;
+  if (BodyPas<>nil) or (bsMethodCallChecks in ImplProcScope.ScannerBoolSwitches) then
     begin
-    BodyPas:=ImplProc.Body;
+    PosEl:=BodyPas;
+    if PosEl=nil then
+      PosEl:=ImplProc;
     BodyJS:=FD.Body;
     FuncContext:=TFunctionContext.Create(ImplProc,FD.Body,AContext);
     try
+      FuncContext.ScannerBoolSwitches:=ImplProcScope.ScannerBoolSwitches;
       FirstSt:=nil;
       LastSt:=nil;
       if ProcScope.ClassScope<>nil then
         begin
         // method or class method
         FuncContext.ThisPas:=ProcScope.ClassScope.Element;
+        if bsMethodCallChecks in FuncContext.ScannerBoolSwitches then
+          begin
+          // rtl.checkMethodCall(this,<class>)
+          Call:=CreateCallExpression(PosEl);
+          AddBodyStatement(Call,PosEl);
+          Call.Expr:=CreateMemberExpression([FBuiltInNames[pbivnRTL],
+                                          FBuiltInNames[pbifnCheckMethodCall]]);
+          Call.AddArg(CreatePrimitiveDotExpr('this',PosEl));
+          ClassPath:=CreateReferencePath(ProcScope.ClassScope.Element,AContext,rpkPathAndName);
+          Call.AddArg(CreatePrimitiveDotExpr(ClassPath,PosEl));
+          end;
+
         if ImplProc.Body.Functions.Count>0 then
           begin
           // has nested procs -> add "var self = this;"
           FuncContext.AddLocalVar(FBuiltInNames[pbivnSelf],FuncContext.ThisPas);
           SelfSt:=CreateVarStatement(FBuiltInNames[pbivnSelf],
                               CreatePrimitiveDotExpr('this',ImplProc),ImplProc);
-          AddBodyStatement(SelfSt,BodyPas);
+          AddBodyStatement(SelfSt,PosEl);
           if ImplProcScope.SelfArg<>nil then
             begin
             // redirect Pascal-Self to JS-Self
@@ -9210,22 +9215,12 @@ begin
       {$IFDEF VerbosePas2JS}
       //FuncContext.WriteStack;
       {$ENDIF}
-      AddBodyStatement(ConvertDeclarations(BodyPas,FuncContext),BodyPas);
+      if BodyPas<>nil then
+        AddBodyStatement(ConvertDeclarations(BodyPas,FuncContext),BodyPas);
     finally
       FuncContext.Free;
     end;
     end;
-  {
-  TPasProcedureBase = class(TPasElement)
-  TPasOverloadedProc = class(TPasProcedureBase)
-  TPasProcedure = class(TPasProcedureBase)
-  TPasFunction = class(TPasProcedure)
-  TPasOperator = class(TPasProcedure)
-  TPasConstructor = class(TPasProcedure)
-  TPasDestructor = class(TPasProcedure)
-  TPasClassProcedure = class(TPasProcedure)
-  TPasClassFunction = class(TPasProcedure)
-  }
 end;
 
 function TPasToJSConverter.ConvertBeginEndStatement(El: TPasImplBeginBlock;
@@ -13139,16 +13134,14 @@ begin
     RaiseInconsistency(20161024190203);
     end;
   C:=El.ClassType;
-  If (C=TPasPackage)  then
-    Result:=ConvertPackage(TPasPackage(El),AContext)
-  else if (C=TPasResString) then
-    Result:=ConvertResString(TPasResString(El),AContext)
-  else if (C=TPasConst) then
+  if (C=TPasConst) then
     Result:=ConvertConst(TPasConst(El),AContext)
   else if (C=TPasProperty) then
     Result:=ConvertProperty(TPasProperty(El),AContext)
   else if (C=TPasVariable) then
     Result:=ConvertVariable(TPasVariable(El),AContext)
+  else if (C=TPasResString) then
+    Result:=ConvertResString(TPasResString(El),AContext)
   else if (C=TPasExportSymbol) then
     Result:=ConvertExportSymbol(TPasExportSymbol(El),AContext)
   else if (C=TPasLabels) then
@@ -13165,6 +13158,8 @@ begin
     Result:=ConvertImplBlock(TPasImplBlock(El),AContext)
   else if C.InheritsFrom(TPasModule)  then
     Result:=ConvertModule(TPasModule(El),AContext)
+  else If (C=TPasPackage)  then
+    Result:=ConvertPackage(TPasPackage(El),AContext)
   else
     begin
     Result:=nil;

packages/pastojs/src/pas2jscompiler.pp

@@ -89,6 +89,9 @@ type
     coShowUsedTools,
     coShowMessageNumbers, // not in "show all"
     coShowDebug,    // not in "show all"
+    coOverflowChecking,
+    coRangeChecking,
+    coMethodCallChecking,
     coAssertions,
     coAllowCAssignments,
     coLowerCase,
@@ -120,6 +123,9 @@ const
     'Show used tools',
     'Show message numbers',
     'Show debug',
+    'Overflow checking',
+    'Range checking',
+    'Method call checking',
     'Assertions',
     'Allow C assignments',
     'Lowercase identifiers',
@@ -338,6 +344,7 @@ type
     procedure ReadParam(Param: string; Quick, FromCmdLine: boolean);
     procedure ReadSingleLetterOptions(const Param: string; p: PChar;
       const Allowed: string; out Enabled, Disabled: string);
+    procedure ReadCodeGenerationFlags(Param: String; p: PChar);
     procedure ReadSyntaxFlags(Param: String; p: PChar);
     procedure ReadVerbosityFlags(Param: String; p: PChar);
     procedure RegisterMessages;
@@ -712,6 +719,12 @@ begin
   Scanner.CurrentModeSwitches:=p2jsMode_SwitchSets[Compiler.Mode];
   Scanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches;
   bs:=[];
+  if coOverflowChecking in Compiler.Options then
+    Include(bs,bsOverflowChecks);
+  if coRangeChecking in Compiler.Options then
+    Include(bs,bsRangeChecks);
+  if coMethodCallChecking in Compiler.Options then
+    Include(bs,bsMethodCallChecks);
   if coAssertions in Compiler.Options then
     Include(bs,bsAssertions);
   if coShowHints in Compiler.Options then
@@ -2268,6 +2281,11 @@ begin
             end;
           end;
         end;
+      'C': // code generation
+        begin
+          inc(p);
+          ReadCodeGenerationFlags(Param,p);
+        end;
       'd': // define
         if not Quick then
         begin
@@ -2592,6 +2610,28 @@ begin
   end;
 end;
 
+procedure TPas2jsCompiler.ReadCodeGenerationFlags(Param: String; p: PChar);
+var
+  Enabled, Disabled: string;
+  i: Integer;
+begin
+  ReadSingleLetterOptions(Param,p,'orR',Enabled,Disabled);
+  for i:=1 to length(Enabled) do begin
+    case Enabled[i] of
+    'o': Options:=Options+[coOverflowChecking];
+    'r': Options:=Options+[coRangeChecking];
+    'R': Options:=Options+[coMethodCallChecking];
+    end;
+  end;
+  for i:=1 to length(Disabled) do begin
+    case Disabled[i] of
+    'o': Options:=Options-[coOverflowChecking];
+    'r': Options:=Options-[coRangeChecking];
+    'R': Options:=Options-[coMethodCallChecking];
+    end;
+  end;
+end;
+
 procedure TPas2jsCompiler.ReadSyntaxFlags(Param: String; p: PChar);
 var
   Enabled, Disabled: string;
@@ -3106,6 +3146,10 @@ begin
   l('    TP    : Write target processor');
   l('    V     : Write short compiler version');
   l('    W     : Write full compiler version');
+  l('  -C<x>   : Code generation options. <x> is a combination of the following letters:');
+  l('    o     : Overflow checking');
+  l('    r     : Range checking');
+  l('    R     : Verify object method call validity');
   l('  -F...   Set file names and paths:');
   l('   -Fe<x> : Redirect output to <x>. UTF-8 encoded.');
   l('   -Fi<x> : Add <x> to include paths');

packages/pastojs/tests/tcmodules.pas

@@ -557,9 +557,10 @@ type
     // Attributes
     Procedure TestAtributes_Ignore;
 
-    // Assertions
+    // Assertions, checks
     procedure TestAssert;
     procedure TestAssert_SysUtils;
+    procedure TestCheckMethodCall;
   end;
 
 function LinesToStr(Args: array of const): string;
@@ -15907,6 +15908,41 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestCheckMethodCall;
+begin
+  Scanner.CurrentBoolSwitches:=Scanner.CurrentBoolSwitches+[bsMethodCallChecks];
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    procedure DoIt;',
+  '  end;',
+  'procedure TObject.DoIt;',
+  'begin',
+  'end;',
+  'var o : TObject;',
+  'begin',
+  '  o.DoIt;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestCheckMethodCall',
+    LinesToStr([ // statements
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '  this.DoIt = function () {',
+    '    rtl.checkMethodCall(this,$mod.TObject);',
+    '  };',
+    '});',
+    'this.o = null;',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.o.DoIt();',
+    '']));
+end;
+
 Initialization
   RegisterTests([TTestModule]);
 end.