paweld/pas2js
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/pas2js.git synced 2025-06-02 04:02:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

pastojs: and/or/xor with nativeint, warn nativeint shl/shr

Browse Source
This commit is contained in:
mattias 2019-02-28 22:02:33 +00:00
parent f9ec6a2196
commit ef6fcf289f
4 changed files with 227 additions and 153 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
compiler/packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -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';

289
compiler/packages/pastojs/src/fppas2js.pp
View File

@ -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

63
compiler/packages/pastojs/tests/tcmodules.pas
View File

@ -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;

24
compiler/utils/pas2js/dist/rtl.js vendored
View File

@ -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');