diff --git a/compiler/packages/fcl-passrc/src/pasresolveeval.pas b/compiler/packages/fcl-passrc/src/pasresolveeval.pas index b86c9b7..73e442f 100644 --- a/compiler/packages/fcl-passrc/src/pasresolveeval.pas +++ b/compiler/packages/fcl-passrc/src/pasresolveeval.pas @@ -181,7 +181,7 @@ const nDerivedXMustExtendASubClassY = 3115; nDefaultPropertyNotAllowedInHelperForX = 3116; nHelpersCannotBeUsedAsTypes = 3117; - nBitWiseOperationsAre32Bit = 3118; + // free 3118 nImplictConversionUnicodeToAnsi = 3119; nWrongTypeXInArrayConstructor = 3120; @@ -312,7 +312,7 @@ resourcestring sDerivedXMustExtendASubClassY = 'Derived %s must extend a subclass of "%s" or the class itself'; sDefaultPropertyNotAllowedInHelperForX = 'Default property not allowed in helper for %s'; sHelpersCannotBeUsedAsTypes = 'helpers cannot be used as types'; - sBitWiseOperationsAre32Bit = 'Bitwise operations are 32-bit'; + // was 3118 sImplictConversionUnicodeToAnsi = 'Implicit string type conversion with potential data loss from "UnicodeString" to "AnsiString"'; sWrongTypeXInArrayConstructor = 'Wrong type "%s" in array constructor'; diff --git a/compiler/packages/pastojs/src/fppas2js.pp b/compiler/packages/pastojs/src/fppas2js.pp index c59c744..c4c63c1 100644 --- a/compiler/packages/pastojs/src/fppas2js.pp +++ b/compiler/packages/pastojs/src/fppas2js.pp @@ -519,6 +519,7 @@ const nCantCallExtBracketAccessor = 4025; nJSNewNotSupported = 4026; nHelperClassMethodForExtClassMustBeStatic = 4027; + nBitWiseOperationIs32Bit = 4028; // resourcestring patterns of messages resourcestring sPasElementNotSupported = 'Pascal element not supported: %s'; @@ -548,6 +549,7 @@ resourcestring sCantCallExtBracketAccessor = 'cannot call external bracket accessor, use a property instead'; sJSNewNotSupported = 'Pascal class does not support the "new" constructor'; sHelperClassMethodForExtClassMustBeStatic = 'Helper class method for external class must be static'; + sBitWiseOperationIs32Bit = 'Bitwise operation is 32-bit'; const ExtClassBracketAccessor = '[]'; // external name '[]' marks the array param getter/setter @@ -565,6 +567,9 @@ type pbifnArray_Static_Clone, pbifnAs, pbifnAsExt, + pbifnBitwiseNativeIntAnd, + pbifnBitwiseNativeIntOr, + pbifnBitwiseNativeIntXor, pbifnCheckMethodCall, pbifnCheckVersion, pbifnClassInstanceFree, @@ -721,6 +726,9 @@ const '$clone', 'as', // rtl.as 'asExt', // rtl.asExt + 'and', // pbifnBitwiseNativeIntAnd, + 'or', // pbifnBitwiseNativeIntOr, + 'xor', // pbifnBitwiseNativeIntXor, 'checkMethodCall', 'checkVersion', '$destroy', @@ -6680,146 +6688,164 @@ begin C:=BinClasses[El.OpCode]; if C=nil then - Case El.OpCode of - eopAs : + Case El.OpCode of + eopAs : + begin + // "A as B" + Call:=CreateCallExpression(El); + LeftTypeEl:=LeftResolved.LoTypeEl; + RightTypeEl:=RightResolved.LoTypeEl; + if LeftTypeEl is TPasClassType then begin - // "A as B" - Call:=CreateCallExpression(El); - LeftTypeEl:=LeftResolved.LoTypeEl; - RightTypeEl:=RightResolved.LoTypeEl; - if LeftTypeEl is TPasClassType then - begin - if RightTypeEl is TPasClassType then - case TPasClassType(LeftTypeEl).ObjKind of + if RightTypeEl is TPasClassType then + case TPasClassType(LeftTypeEl).ObjKind of + okClass: + case TPasClassType(RightTypeEl).ObjKind of okClass: - case TPasClassType(RightTypeEl).ObjKind of - okClass: - // ClassInstVar is ClassType - if TPasClassType(RightResolved.LoTypeEl).IsExternal then - // B is external class -> "rtl.asExt(A,B)" - Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnAsExt),El) - else - // otherwise -> "rtl.as(A,B)" - Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnAs),El); - okInterface: - begin - // ClassInstVar as IntfType - case TPasClassType(RightTypeEl).InterfaceType of - citCom: - begin - // COM: $ir.ref(rtl.queryIntfT(objVar,intftype),"id") - Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnIntfQueryIntfT),El); - Call.AddArg(A); - Call.AddArg(B); - Call:=CreateIntfRef(Call,AContext,El); - Result:=Call; - exit; - end; - citCorba: - // CORBA: rtl.getIntfT(objVar,intftype) - Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnIntfGetIntfT),El); - else RaiseNotSupported(El,AContext,20180401225752); - end; - end + // ClassInstVar is ClassType + if TPasClassType(RightResolved.LoTypeEl).IsExternal then + // B is external class -> "rtl.asExt(A,B)" + Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnAsExt),El) else - NotSupportedRes(20180327214535); - end; - okInterface: - case TPasClassType(RightTypeEl).ObjKind of - okClass: - // IntfVar as ClassType -> rtl.intfAsClass(intfvar,classtype) - Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnIntfAsClass),El); - okInterface: - // IntfVar as IntfType -> "rtl.as(A,B)" + // otherwise -> "rtl.as(A,B)" Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnAs),El); - else - NotSupportedRes(20180327214545); + okInterface: + begin + // ClassInstVar as IntfType + case TPasClassType(RightTypeEl).InterfaceType of + citCom: + begin + // COM: $ir.ref(rtl.queryIntfT(objVar,intftype),"id") + Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnIntfQueryIntfT),El); + Call.AddArg(A); + Call.AddArg(B); + Call:=CreateIntfRef(Call,AContext,El); + Result:=Call; + exit; + end; + citCorba: + // CORBA: rtl.getIntfT(objVar,intftype) + Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnIntfGetIntfT),El); + else RaiseNotSupported(El,AContext,20180401225752); end; + end else - NotSupportedRes(20180327214559); - end - else if RightTypeEl is TPasClassOfType then - begin - // ClassInstVar is ClassOfType -> "rtl.as(A,B)" - Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnAs),El); + NotSupportedRes(20180327214535); end; + okInterface: + case TPasClassType(RightTypeEl).ObjKind of + okClass: + // IntfVar as ClassType -> rtl.intfAsClass(intfvar,classtype) + Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnIntfAsClass),El); + okInterface: + // IntfVar as IntfType -> "rtl.as(A,B)" + Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnAs),El); + else + NotSupportedRes(20180327214545); + end; + else + NotSupportedRes(20180327214559); + end + else if RightTypeEl is TPasClassOfType then + begin + // ClassInstVar is ClassOfType -> "rtl.as(A,B)" + Call.Expr:=CreatePrimitiveDotExpr(GetBIName(pbivnRTL)+'.'+GetBIName(pbifnAs),El); end; - Call.AddArg(A); - Call.AddArg(B); - Result:=Call; - exit; end; - eopAnd: + Call.AddArg(A); + Call.AddArg(B); + Result:=Call; + exit; + end; + eopAnd: + begin + if aResolver<>nil then begin - if aResolver<>nil then + UseBitwiseOp:=((LeftResolved.BaseType in btAllJSInteger) + or (RightResolved.BaseType in btAllJSInteger)); + if UseBitwiseOp + and (LeftResolved.BaseType in [btIntDouble,btUIntDouble]) + and (RightResolved.BaseType in [btIntDouble,btUIntDouble]) then begin - UseBitwiseOp:=((LeftResolved.BaseType in btAllJSInteger) - or (RightResolved.BaseType in btAllJSInteger)); - if UseBitwiseOp - and (LeftResolved.BaseType in [btIntDouble,btUIntDouble]) - and (RightResolved.BaseType in [btIntDouble,btUIntDouble]) then - aResolver.LogMsg(20190124233439,mtWarning,nBitWiseOperationsAre32Bit, - sBitWiseOperationsAre32Bit,[],El); - end - else - UseBitwiseOp:=(GetExpressionValueType(El.left,AContext)=jstNumber) - or (GetExpressionValueType(El.right,AContext)=jstNumber); - if UseBitwiseOp then - C:=TJSBitwiseAndExpression - else - C:=TJSLogicalAndExpression; - end; - eopOr: - begin - if aResolver<>nil then - begin - UseBitwiseOp:=((LeftResolved.BaseType in btAllJSInteger) - or (RightResolved.BaseType in btAllJSInteger)); - if UseBitwiseOp - and ((LeftResolved.BaseType in [btIntDouble,btUIntDouble]) - or (RightResolved.BaseType in [btIntDouble,btUIntDouble])) then - aResolver.LogMsg(20190228220145,mtWarning,nBitWiseOperationsAre32Bit, - sBitWiseOperationsAre32Bit,[],El); - end - else - UseBitwiseOp:=(GetExpressionValueType(El.left,AContext)=jstNumber) - or (GetExpressionValueType(El.right,AContext)=jstNumber); - if UseBitwiseOp then - C:=TJSBitwiseOrExpression - else - C:=TJSLogicalOrExpression; - end; - eopXor: - begin - if aResolver<>nil then - begin - UseBitwiseOp:=((LeftResolved.BaseType in btAllJSInteger) - or (RightResolved.BaseType in btAllJSInteger)); - if UseBitwiseOp - and ((LeftResolved.BaseType in [btIntDouble,btUIntDouble]) - or (RightResolved.BaseType in [btIntDouble,btUIntDouble])) then - aResolver.LogMsg(20190228220225,mtWarning,nBitWiseOperationsAre32Bit, - sBitWiseOperationsAre32Bit,[],El); - end - else - UseBitwiseOp:=(GetExpressionValueType(El.left,AContext)=jstNumber) - or (GetExpressionValueType(El.right,AContext)=jstNumber); - if UseBitwiseOp then - C:=TJSBitwiseXOrExpression - else - C:=TJSBitwiseXOrExpression; - end; - eopPower: - begin - Call:=CreateCallExpression(El); - Call.Expr:=CreatePrimitiveDotExpr('Math.pow',El); - Call.AddArg(A); - Call.AddArg(B); - Result:=Call; + Call:=CreateCallExpression(El); + Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnBitwiseNativeIntAnd)]); + Call.AddArg(A); + Call.AddArg(B); + Result:=Call; + exit; + end; end else - if C=nil then - DoError(20161024191244,nBinaryOpcodeNotSupported,sBinaryOpcodeNotSupported,[OpcodeStrings[El.OpCode]],El); + UseBitwiseOp:=(GetExpressionValueType(El.left,AContext)=jstNumber) + or (GetExpressionValueType(El.right,AContext)=jstNumber); + if UseBitwiseOp then + C:=TJSBitwiseAndExpression + else + C:=TJSLogicalAndExpression; + end; + eopOr: + begin + if aResolver<>nil then + begin + UseBitwiseOp:=((LeftResolved.BaseType in btAllJSInteger) + or (RightResolved.BaseType in btAllJSInteger)); + if UseBitwiseOp + and ((LeftResolved.BaseType in [btIntDouble,btUIntDouble]) + or (RightResolved.BaseType in [btIntDouble,btUIntDouble])) then + begin + Call:=CreateCallExpression(El); + Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnBitwiseNativeIntOr)]); + Call.AddArg(A); + Call.AddArg(B); + Result:=Call; + exit; + end; + end + else + UseBitwiseOp:=(GetExpressionValueType(El.left,AContext)=jstNumber) + or (GetExpressionValueType(El.right,AContext)=jstNumber); + if UseBitwiseOp then + C:=TJSBitwiseOrExpression + else + C:=TJSLogicalOrExpression; + end; + eopXor: + begin + if aResolver<>nil then + begin + UseBitwiseOp:=((LeftResolved.BaseType in btAllJSInteger) + or (RightResolved.BaseType in btAllJSInteger)); + if UseBitwiseOp + and ((LeftResolved.BaseType in [btIntDouble,btUIntDouble]) + or (RightResolved.BaseType in [btIntDouble,btUIntDouble])) then + begin + Call:=CreateCallExpression(El); + Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnBitwiseNativeIntXor)]); + Call.AddArg(A); + Call.AddArg(B); + Result:=Call; + exit; + end; + end + else + UseBitwiseOp:=(GetExpressionValueType(El.left,AContext)=jstNumber) + or (GetExpressionValueType(El.right,AContext)=jstNumber); + if UseBitwiseOp then + C:=TJSBitwiseXOrExpression + else + C:=TJSBitwiseXOrExpression; + end; + eopPower: + begin + Call:=CreateCallExpression(El); + Call.Expr:=CreatePrimitiveDotExpr('Math.pow',El); + Call.AddArg(A); + Call.AddArg(B); + Result:=Call; + end; + else + if C=nil then + DoError(20161024191244,nBinaryOpcodeNotSupported,sBinaryOpcodeNotSupported,[OpcodeStrings[El.OpCode]],El); end; if (Result=Nil) and (C<>Nil) then begin @@ -6828,11 +6854,18 @@ begin R.B:=B; B:=nil; Result:=R; - if El.OpCode=eopDiv then + case El.OpCode of + eopDiv: begin // convert "a div b" to "Math.floor(a/b)" Result:=CreateMathFloor(El,Result); end; + eopShl,eopShr: + if (aResolver<>nil) and (LeftResolved.BaseType in [btIntDouble,btUIntDouble]) then + aResolver.LogMsg(20190228220225,mtWarning,nBitWiseOperationIs32Bit, + sBitWiseOperationIs32Bit,[],El); + end; + end; finally if Result=nil then diff --git a/compiler/packages/pastojs/tests/tcmodules.pas b/compiler/packages/pastojs/tests/tcmodules.pas index 8c2ce17..24e31af 100644 --- a/compiler/packages/pastojs/tests/tcmodules.pas +++ b/compiler/packages/pastojs/tests/tcmodules.pas @@ -263,7 +263,7 @@ type Procedure TestInteger; Procedure TestIntegerRange; Procedure TestIntegerTypecasts; - Procedure TestBitwiseAndNativeIntWarn; + Procedure TestBitwiseShlNativeIntWarn; Procedure TestCurrency; Procedure TestForBoolDo; Procedure TestForIntDo; @@ -3075,24 +3075,36 @@ end; procedure TTestModule.TestBitwiseOperators; begin StartProgram(false); - Add('var'); - Add(' vA,vB,vC:longint;'); - Add('begin'); - Add(' va:=vb and vc;'); - Add(' va:=vb or vc;'); - Add(' va:=vb xor vc;'); - Add(' va:=vb shl vc;'); - Add(' va:=vb shr vc;'); - Add(' va:=3 and vc;'); - Add(' va:=(vb and vc) or (va and vb);'); - Add(' va:=not vb;'); + Add([ + 'var', + ' vA,vB,vC:longint;', + ' X,Y,Z: nativeint;', + 'begin', + ' va:=vb and vc;', + ' va:=vb or vc;', + ' va:=vb xor vc;', + ' va:=vb shl vc;', + ' va:=vb shr vc;', + ' va:=3 and vc;', + ' va:=(vb and vc) or (va and vb);', + ' va:=not vb;', + ' X:=Y and Z;', + ' X:=Y and va;', + ' X:=Y or Z;', + ' X:=Y or va;', + ' X:=Y xor Z;', + ' X:=Y xor va;', + '']); ConvertProgram; CheckSource('TestBitwiseOperators', LinesToStr([ // statements 'this.vA = 0;', 'this.vB = 0;', - 'this.vC = 0;' - ]), + 'this.vC = 0;', + 'this.X = 0;', + 'this.Y = 0;', + 'this.Z = 0;', + '']), LinesToStr([ // this.$main '$mod.vA = $mod.vB & $mod.vC;', '$mod.vA = $mod.vB | $mod.vC;', @@ -3101,8 +3113,14 @@ begin '$mod.vA = $mod.vB >>> $mod.vC;', '$mod.vA = 3 & $mod.vC;', '$mod.vA = ($mod.vB & $mod.vC) | ($mod.vA & $mod.vB);', - '$mod.vA = ~$mod.vB;' - ])); + '$mod.vA = ~$mod.vB;', + '$mod.X = rtl.and($mod.Y, $mod.Z);', + '$mod.X = $mod.Y & $mod.vA;', + '$mod.X = rtl.or($mod.Y, $mod.Z);', + '$mod.X = rtl.or($mod.Y, $mod.vA);', + '$mod.X = rtl.xor($mod.Y, $mod.Z);', + '$mod.X = rtl.xor($mod.Y, $mod.vA);', + ''])); end; procedure TTestModule.TestPrgProcVar; @@ -6409,25 +6427,24 @@ begin ''])); end; -procedure TTestModule.TestBitwiseAndNativeIntWarn; +procedure TTestModule.TestBitwiseShlNativeIntWarn; begin StartProgram(false); Add([ 'var', - ' i,j: nativeint;', + ' i: nativeint;', 'begin', - ' i:=i and j;', + ' i:=i shl 3;', '']); ConvertProgram; - CheckSource('TestBitwiseAndNativeIntWarn', + CheckSource('TestBitwiseShlNativeIntWarn', LinesToStr([ 'this.i = 0;', - 'this.j = 0;', '']), LinesToStr([ - '$mod.i = $mod.i & $mod.j;', + '$mod.i = $mod.i << 3;', ''])); - CheckHint(mtWarning,nBitWiseOperationsAre32Bit,sBitWiseOperationsAre32Bit); + CheckHint(mtWarning,nBitWiseOperationIs32Bit,sBitWiseOperationIs32Bit); end; procedure TTestModule.TestCurrency; diff --git a/compiler/utils/pas2js/dist/rtl.js b/compiler/utils/pas2js/dist/rtl.js index 6ee23c0..e8e3da3 100644 --- a/compiler/utils/pas2js/dist/rtl.js +++ b/compiler/utils/pas2js/dist/rtl.js @@ -1058,6 +1058,30 @@ var rtl = { return 0; }, + and: function(a,b){ + var hi = 0x80000000; + var low = 0x7fffffff; + var h = (a / hi) & (b / hi); + var l = (a & low) & (b & low); + return h*hi + l; + }, + + or: function(a,b){ + var hi = 0x80000000; + var low = 0x7fffffff; + var h = (a / hi) | (b / hi); + var l = (a & low) | (b & low); + return h*hi + l; + }, + + xor: function(a,b){ + var hi = 0x80000000; + var low = 0x7fffffff; + var h = (a / hi) ^ (b / hi); + var l = (a & low) ^ (b & low); + return h*hi + l; + }, + initRTTI: function(){ if (rtl.debug_rtti) rtl.debug('initRTTI');