diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 151db9e82b..fb22257b8f 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/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,) + 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; diff --git a/packages/pastojs/src/pas2jscompiler.pp b/packages/pastojs/src/pas2jscompiler.pp index c117be0606..be3a179c30 100644 --- a/packages/pastojs/src/pas2jscompiler.pp +++ b/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 : Code generation options. 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 : Redirect output to . UTF-8 encoded.'); l(' -Fi : Add to include paths'); diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index a2cfc2d325..4029a82e53 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/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.