From 4fdeada0a5b43442f09ebe64cee3cac9f2a2a860 Mon Sep 17 00:00:00 2001
From: mattias <nc-gaertnma@netcologne.de>
Date: Wed, 18 Aug 2021 09:45:26 +0200
Subject: [PATCH] pastojs: emulate compile time assign integer constant of
different type
---
packages/fcl-passrc/src/pasresolveeval.pas | 4 +-
packages/fcl-passrc/src/pasresolver.pp | 22 ++++-
packages/pastojs/src/fppas2js.pp | 107 ++++++++++++++++++++-
packages/pastojs/tests/tcmodules.pas | 105 +++++++++++++++++++-
4 files changed, 230 insertions(+), 8 deletions(-)
diff --git a/packages/fcl-passrc/src/pasresolveeval.pas b/packages/fcl-passrc/src/pasresolveeval.pas
index ef77d79f55..3731543297 100644
--- a/packages/fcl-passrc/src/pasresolveeval.pas
+++ b/packages/fcl-passrc/src/pasresolveeval.pas
@@ -787,7 +787,7 @@ type
function EvalStrFunc(Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
function EvalStringAddExpr(Expr, LeftExpr, RightExpr: TPasExpr;
LeftValue, RightValue: TResEvalValue): TResEvalValue; virtual;
- function LoHiValue(Value: TResEvalValue; ShiftSize: Integer; Mask: LongWord;
+ function ShiftAndMaskValue(Value: TResEvalValue; ShiftSize: Integer; Mask: LongWord;
ErrorEl: TPasElement): TResEvalValue; virtual;
function EnumTypeCast(EnumType: TPasEnumType; Expr: TPasExpr;
Flags: TResEvalFlags): TResEvalEnum; virtual;
@@ -5273,7 +5273,7 @@ begin
end;
end;
-function TResExprEvaluator.LoHiValue(Value: TResEvalValue; ShiftSize: Integer;
+function TResExprEvaluator.ShiftAndMaskValue(Value: TResEvalValue; ShiftSize: Integer;
Mask: LongWord; ErrorEl: TPasElement): TResEvalValue;
var
uint: LongWord;
diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp
index f6619307a2..45d10fea4c 100644
--- a/packages/fcl-passrc/src/pasresolver.pp
+++ b/packages/fcl-passrc/src/pasresolver.pp
@@ -20088,7 +20088,7 @@ begin
try
ComputeElement(Param,ResolvedParam,[]);
Shift := GetShiftAndMaskForLoHiFunc(ResolvedParam.BaseType, Proc.BuiltIn=bfLo, Mask);
- Evaluated := fExprEvaluator.LoHiValue(Value,Shift,Mask,Params);
+ Evaluated := fExprEvaluator.ShiftAndMaskValue(Value,Shift,Mask,Params);
finally
ReleaseEvalValue(Value);
end;
@@ -27920,7 +27920,7 @@ begin
writeln('TPasResolver.ComputeElement Unary Kind=',TUnaryExpr(El).Kind,' OpCode=',TUnaryExpr(El).OpCode,' OperandResolved=',GetResolverResultDbg(ResolvedEl),' ',GetElementSourcePosStr(El));
{$ENDIF}
case TUnaryExpr(El).OpCode of
- eopAdd, eopSubtract:
+ eopAdd:
if ResolvedEl.BaseType in (btAllInteger+btAllFloats) then
exit
else if IsGenericTemplType(ResolvedEl) then
@@ -27928,6 +27928,24 @@ begin
else
RaiseMsg(20170216152532,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf,
[OpcodeStrings[TUnaryExpr(El).OpCode],GetResolverResultDescription(ResolvedEl)],El);
+ eopSubtract:
+ if ResolvedEl.BaseType in (btAllSignedInteger+btAllFloats) then
+ exit
+ else if ResolvedEl.BaseType in btAllInteger then
+ begin
+ case ResolvedEl.BaseType of
+ btByte,btWord:
+ ResolvedEl.BaseType:=btLongint;
+ btLongWord,btUIntDouble:
+ ResolvedEl.BaseType:=btIntDouble;
+ end;
+ exit;
+ end
+ else if IsGenericTemplType(ResolvedEl) then
+ exit
+ else
+ RaiseMsg(20210815225815,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf,
+ [OpcodeStrings[TUnaryExpr(El).OpCode],GetResolverResultDescription(ResolvedEl)],El);
eopNot:
begin
if ResolvedEl.BaseType in (btAllInteger+btAllBooleans) then
diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp
index 9ebb12f78d..a520805493 100644
--- a/packages/pastojs/src/fppas2js.pp
+++ b/packages/pastojs/src/fppas2js.pp
@@ -462,6 +462,9 @@ unit FPPas2Js;
{$define HasInt64}
{$endif}
+{$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF}
+{$IFOPT R+}{$DEFINE RangeCheckOn}{$ENDIF}
+
interface
uses
@@ -2076,6 +2079,7 @@ type
RTLFunc: TPas2JSBuiltInName; PosEl: TPasElement): TJSCallExpression; virtual;
Function CreateRangeCheckCall_TypeRange(aType: TPasType; GetExpr: TJSElement;
AContext: TConvertContext; PosEl: TPasElement): TJSCallExpression; virtual;
+ Procedure PrepareAssignDifferentIntegers(El: TPasImplAssign; AssignContext: TAssignContext); virtual;
// reference
Function CreateReferencePath(El: TPasElement; AContext: TConvertContext;
Kind: TRefPathKind; Full: boolean = false; Ref: TResolvedReference = nil): string; virtual;
@@ -13745,7 +13749,6 @@ begin
end;
btString:
begin
- writeln('AAA1 TPasToJSConverter.ConvertBuiltIn_LowHigh ',IsLow);
if isLow then
// low(aString) -> 1
Result:=CreateLiteralNumber(El,1)
@@ -14262,7 +14265,7 @@ begin
RaiseInconsistency(20190129102200,El);
Param := El.Params[0];
AContext.Resolver.ComputeElement(Param,ResolvedParam,[]);
- if not (ResolvedParam.BaseType in btAllInteger) then
+ if not (ResolvedParam.BaseType in btAllJSInteger) then
DoError(20190129121100,nXExpectedButYFound,sXExpectedButYFound,['integer type',
AContext.Resolver.GetResolverResultDescription(ResolvedParam)],Param);
Shift := AContext.Resolver.GetShiftAndMaskForLoHiFunc(ResolvedParam.BaseType,IsLoFunc,Mask);
@@ -22301,6 +22304,7 @@ begin
end;
if AssignContext.RightSide=nil then
AssignContext.RightSide:=ConvertExpression(El.right,AContext);
+
if (AssignContext.RightResolved.BaseType in [btSet,btArrayOrSet])
and (AssignContext.RightResolved.IdentEl<>nil) then
begin
@@ -22335,6 +22339,13 @@ begin
// e.g. double := currency -> double := currency/10000
AssignContext.RightSide:=CreateDivideNumber(El,AssignContext.RightSide,10000);
end
+ else if (AssignContext.LeftResolved.BaseType<>AssignContext.RightResolved.BaseType)
+ and (AssignContext.LeftResolved.BaseType in btAllJSInteger)
+ and (AssignContext.RightResolved.BaseType in btAllJSInteger) then
+ begin
+ // AnInteger := OtherInteger
+ PrepareAssignDifferentIntegers(El,AssignContext);
+ end
else if AssignContext.RightResolved.BaseType in btAllStringAndChars then
begin
if AssignContext.LeftResolved.BaseType=btContext then
@@ -22539,6 +22550,7 @@ begin
if (bsRangeChecks in AContext.ScannerBoolSwitches)
and not (T.Expr is TJSLiteral) then
begin
+ // range checks
if AssignContext.LeftResolved.BaseType in btAllJSInteger then
begin
if LeftTypeEl is TPasUnresolvedSymbolRef then
@@ -24800,6 +24812,97 @@ begin
end;
end;
+procedure TPasToJSConverter.PrepareAssignDifferentIntegers(El: TPasImplAssign;
+ AssignContext: TAssignContext);
+
+ function CutToUIntDouble(IntValue: TMaxPrecInt): TMaxPrecInt;
+ begin
+ {$IFDEF pas2js}
+ Result:=((IntValue div $80000000) and $003fffff)*$80000000 +(IntValue and $7FFFFFFF);
+ {$ELSE}
+ Result:=IntValue and MaxSafeIntDouble;
+ {$ENDIF}
+ end;
+
+var
+ aResolver: TPas2JSResolver;
+ LeftBT, RightBT: TResolverBaseType;
+ Value: TResEvalValue;
+ IntValue, LeftMinVal, LeftMaxVal, RightMinVal, RightMaxVal: TMaxPrecInt;
+begin
+ aResolver:=AssignContext.Resolver;
+ LeftBT:=AssignContext.LeftResolved.BaseType;
+ RightBT:=AssignContext.RightResolved.BaseType;
+
+ if not aResolver.GetIntegerRange(LeftBT,LeftMinVal,LeftMaxVal) then
+ RaiseNotSupported(El.left,AssignContext,20210815195159);
+ if not aResolver.GetIntegerRange(RightBT,RightMinVal,RightMaxVal) then
+ RaiseNotSupported(El.right,AssignContext,20210815195228);
+ if (LeftMinVal<=RightMinVal) and (LeftMaxVal>=RightMaxVal) then
+ exit; // right is subset of left
+
+ // right might not fit into left
+
+ Value:=aResolver.Eval(El.right,[]);
+ try
+ if Value<>nil then
+ begin
+ if Value.Kind=revkInt then
+ begin
+ IntValue:=TResEvalInt(Value).Int;
+ if (IntValue>=LeftMinVal) and (IntValue<=LeftMaxVal) then
+ exit;
+ end
+ else if Value.Kind=revkUInt then
+ begin
+ if TResEvalUInt(Value).UInt<=HighIntAsUInt then
+ begin
+ IntValue:=TMaxPrecInt(TResEvalUInt(Value).UInt);
+ if (IntValue>=LeftMinVal) and (IntValue<=LeftMaxVal) then
+ exit;
+ end
+ else
+ {$IFDEF Pas2js}
+ RaiseNotSupported(El.right,AssignContext,20210815214534);
+ {$ELSE}
+ IntValue:=PMaxPrecInt(@TResEvalUInt(Value).UInt)^;
+ {$ENDIF}
+ end
+ else
+ RaiseNotSupported(El.right,AssignContext,20210815204203,'right='+Value.AsDebugString);
+
+ case LeftBT of
+ btByte: IntValue:=IntValue and $FF; // Note: "and" handles negative numbers
+ btShortInt:
+ begin
+ IntValue:=(IntValue and $FF);
+ if IntValue>$7F then IntValue:=IntValue-$100;
+ end;
+ btWord: IntValue:=IntValue and $FFFF;
+ btSmallInt:
+ begin
+ IntValue:=(IntValue and $FFFF);
+ if IntValue>$7FFF then IntValue:=IntValue-$10000;
+ end;
+ btLongWord: IntValue:=IntValue and $FFFFFFFF;
+ btLongint:
+ begin
+ IntValue:=(IntValue and $FFFFFFFF);
+ if IntValue>$7FFFFFFF then IntValue:=IntValue-$100000000;
+ end;
+ btUIntDouble:
+ IntValue:=CutToUIntDouble(IntValue);
+ btIntDouble:
+ IntValue:=CutToUIntDouble(IntValue);
+ end;
+
+ AssignContext.RightSide:=CreateLiteralNumber(El.right,IntValue);
+ end;
+ finally
+ ReleaseEvalValue(Value);
+ end;
+end;
+
function TPasToJSConverter.CreateReferencePath(El: TPasElement;
AContext: TConvertContext; Kind: TRefPathKind; Full: boolean;
Ref: TResolvedReference): string;
diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas
index 9bc86951a8..c258b255de 100644
--- a/packages/pastojs/tests/tcmodules.pas
+++ b/packages/pastojs/tests/tcmodules.pas
@@ -277,6 +277,7 @@ type
Procedure TestInteger_BitwiseShrNativeInt;
Procedure TestInteger_BitwiseShlNativeInt;
Procedure TestInteger_SystemFunc;
+ Procedure TestInteger_AssignOutsideConst;
Procedure TestCurrency;
Procedure TestForBoolDo;
Procedure TestForIntDo;
@@ -3159,8 +3160,8 @@ begin
'this.HiByte2 = (0x1234 >> 8) & 0xFF;',
'this.LoWord1 = 0x1234CDEF & 0xFFFF;',
'this.HiWord1 = (0x1234CDEF >> 16) & 0xFFFF;',
- 'this.LoWord2 = -0x1234CDEF & 0xFFFF;',
- 'this.HiWord2 = (-0x1234CDEF >> 16) & 0xFFFF;',
+ 'this.LoWord2 = -0x1234CDEF >>> 0;',
+ 'this.HiWord2 = Math.floor(-0x1234CDEF / 4294967296) >>> 0;',
'this.lo4 = 0x34 & 0xF;',
'this.hi4 = (0x34 >> 4) & 0xF;',
'this.lo5 = (((-0x34 & 255) << 24) >> 24) & 0xFF;',
@@ -7463,6 +7464,106 @@ begin
'']));
end;
+procedure TTestModule.TestInteger_AssignOutsideConst;
+begin
+ StartProgram(false);
+ Add([
+ 'const',
+ ' MinInt = low(longint);',
+ ' MaxInt = high(longint);',
+ 'type',
+ ' {#TMyInt}TMyInt = MinInt..MaxInt;',
+ 'var',
+ ' i: TMyInt;',
+ ' aByte: byte;',
+ ' aShortInt: shortint;',
+ ' aWord: word;',
+ ' aSmallInt: smallint;',
+ ' aLongWord: longword;',
+ ' aLongInt: longint;',
+ ' aNativeInt: nativeint;',
+ ' aNativeUInt: nativeuint;',
+ 'begin',
+ ' aByte:=$FF;',
+ ' aByte:=$100;',
+ ' aByte:=-1;',
+ ' aByte:=-127;',
+ ' aByte:=-128;',
+ ' aByte:=-254;',
+ ' aByte:=-255;',
+ ' aByte:=-256;',
+ ' aShortInt:=127;',
+ ' aShortInt:=128;',
+ ' aShortInt:=-128;',
+ ' aShortInt:=-129;',
+ ' aWord:=$ffff;',
+ ' aWord:=$10000;',
+ ' aWord:=-1;',
+ ' aWord:=-$ffff;',
+ ' aWord:=-$10000;',
+ ' aWord:=-$10001;',
+ ' aSmallInt:=$7fff;',
+ ' aSmallInt:=$8000;',
+ ' aSmallInt:=-$8000;',
+ ' aSmallInt:=-$8001;',
+ ' aLongWord:=$ffffffff;',
+ ' aLongWord:=$100000000;',
+ ' aLongWord:=-1;',
+ ' aLongWord:=-$ffffffff;',
+ ' aNativeInt:=$1fffffffffffff;',
+ ' aNativeInt:=-$1fffffffffffff;',
+ ' aNativeUInt:=$1fffffffffffff;',
+ ' aNativeUInt:=-$1fffffffffffff;',
+ '']);
+ ConvertProgram;
+ CheckSource('TestInteger_AssignOutsideConst',
+ LinesToStr([
+ 'this.MinInt = -2147483648;',
+ 'this.MaxInt = 2147483647;',
+ 'this.i = 0;',
+ 'this.aByte = 0;',
+ 'this.aShortInt = 0;',
+ 'this.aWord = 0;',
+ 'this.aSmallInt = 0;',
+ 'this.aLongWord = 0;',
+ 'this.aLongInt = 0;',
+ 'this.aNativeInt = 0;',
+ 'this.aNativeUInt = 0;',
+ '']),
+ LinesToStr([
+ '$mod.aByte = 0xFF;',
+ '$mod.aByte = 0;',
+ '$mod.aByte = 255;',
+ '$mod.aByte = 129;',
+ '$mod.aByte = 128;',
+ '$mod.aByte = 2;',
+ '$mod.aByte = 1;',
+ '$mod.aByte = 0;',
+ '$mod.aShortInt = 127;',
+ '$mod.aShortInt = -128;',
+ '$mod.aShortInt = -128;',
+ '$mod.aShortInt = 127;',
+ '$mod.aWord = 0xffff;',
+ '$mod.aWord = 0;',
+ '$mod.aWord = 65535;',
+ '$mod.aWord = 1;',
+ '$mod.aWord = 0;',
+ '$mod.aWord = 65535;',
+ '$mod.aSmallInt = 0x7fff;',
+ '$mod.aSmallInt = -32768;',
+ '$mod.aSmallInt = -0x8000;',
+ '$mod.aSmallInt = 32767;',
+ '$mod.aLongWord = 0xffffffff;',
+ '$mod.aLongWord = 0;',
+ '$mod.aLongWord = 4294967295;',
+ '$mod.aLongWord = 1;',
+ '$mod.aNativeInt = 0x1fffffffffffff;',
+ '$mod.aNativeInt = -0x1fffffffffffff;',
+ '$mod.aNativeUInt = 0x1fffffffffffff;',
+ '$mod.aNativeUInt = 1;',
+ '']));
+end;
+
procedure TTestModule.TestCurrency;
begin
StartProgram(false);