paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 16:09:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: const eval: pred(), succ(), ord()

Browse Source 
git-svn-id: trunk@36601 -
This commit is contained in:
Mattias Gaertner 2017-06-26 16:21:32 +00:00
parent 84b08b61a8
commit 8935b3c05c
5 changed files with 613 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

425
packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -17,42 +17,45 @@ Abstract:
Evaluation of Pascal constants.
Works:
- Emitting range check warnings
- Error on overflow
- bool: not, =, <>, and, or, xor, low(), high()
- int/uint
- unary +, -
- binary: +, -, *, div, mod, ^^, =, <>, <, >, <=, >=, and, or, xor, not
- string: +
- float:
- enum/set
- Emitting range check warnings
- Error on overflow
- bool: not, =, <>, and, or, xor, low(), high(), pred(), succ(), ord()
- int/uint
- unary +, -
- binary: +, -, *, div, mod, ^^, =, <>, <, >, <=, >=, and, or, xor, not
- low(), high(), pred(), succ(), ord()
- typecast int
- string:
- +
- pred(), succ()
- float:
- enum/set
ToDo:
- enable eval via option, default off
- bool:
- low(), high(), pred(), succ(), ord()
- int
- typecast
- low(), high(), pred(), succ()
- string:
- =, <>, <, >, <=, >=
- string encoding
- s[]
- length(string)
- chr(), ord(), low(), high(), pred(), succ()
- #65
- #$DC00
- float
- typecast float
- /
- +, -, *, div, mod, ^^, =, <>, <, >, <=, >=, and, or, xor, not
- enum
- low(), high(), pred(), succ(), ord(), typecast
- sets
- [a,b,c..d]
- +, -, *, =, <>, <=, >=, in, ><
- arrays
- length(), low(), high()
- enable eval via option, default off
- bool:
- boolean(1)
- int
- typecast intsingle(-1), uintsingle(-1), longint(-1)
- string:
- =, <>, <, >, <=, >=
- string encoding
- s[]
- length(string)
- chr(), ord(), low(), high()
- #65
- #$DC00
- float
- typecast float
- /
- +, -, *, div, mod, ^^, =, <>, <, >, <=, >=, and, or, xor, not
- enum
- low(), high(), pred(), succ(), ord(), typecast
- sets
- [a,b,c..d]
- +, -, *, =, <>, <=, >=, in, ><
- arrays
- length(), low(), high()
}
unit PasResolveEval;
@ -235,6 +238,16 @@ const
// possibly resulting in a range check error -> using a qword const instead
HighIntAsUInt = MaxPrecUInt(High(MaxPrecInt));
const
MinSafeIntCurrency = -922337203685477;
MaxSafeIntCurrency = 922337203685477;
MinSafeIntSingle = -16777216;
MaxSafeIntSingle = 16777216;
MaskUIntSingle = $3fffff;
MinSafeIntDouble = -$10000000000000;
MaxSafeIntDouble = $fffffffffffff;
MaskUIntDouble = $fffffffffffff;
type
{ TResEvalValue }
@ -276,15 +289,38 @@ type
function AsString: string; override;
end;
TResEvalTypedInt = (
reitNone,
reitByte,
reitShortInt,
reitWord,
reitSmallInt,
reitUIntSingle,
reitIntSingle,
reitLongWord,
reitLongInt,
reitUIntDouble,
reitIntDouble);
TResEvalTypedInts = set of TResEvalTypedInt;
const
reitDefaults = [reitNone,reitByte,reitShortInt,reitWord,reitSmallInt,reitLongWord,reitLongInt];
reitAllSigned = [reitNone,reitShortInt,reitSmallInt,reitIntSingle,reitLongInt,reitIntDouble];
reitAllUnsigned = [reitByte,reitWord,reitUIntSingle,reitLongWord,reitUIntDouble];
type
{ TResEvalInt }
TResEvalInt = class(TResEvalValue)
public
Int: MaxPrecInt;
Typed: TResEvalTypedInt;
constructor Create; override;
constructor CreateValue(const aValue: MaxPrecInt);
constructor CreateValue(const aValue: MaxPrecInt; aTyped: TResEvalTypedInt);
function Clone: TResEvalValue; override;
function AsString: string; override;
function AsDebugString: string; override;
end;
{ TResEvalUInt }
@ -421,6 +457,7 @@ type
TResExprEvaluator = class
private
FAllowedInts: TResEvalTypedInts;
FOnEvalIdentifier: TPasResEvalIdentHandler;
FOnEvalParams: TPasResEvalParamsHandler;
FOnLog: TPasResEvalLogHandler;
@ -453,8 +490,21 @@ type
function EvalSetParams(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue;
function ExprStringToOrd(Value: TResEvalValue; PosEl: TPasElement): longword; virtual;
function EvalPrimitiveExprString(Expr: TPrimitiveExpr): TResEvalValue; virtual;
procedure PredBool(Value: TResEvalBool; ErrorEl: TPasElement);
procedure SuccBool(Value: TResEvalBool; ErrorEl: TPasElement);
procedure PredInt(Value: TResEvalInt; ErrorEl: TPasElement);
procedure SuccInt(Value: TResEvalInt; ErrorEl: TPasElement);
procedure PredUInt(Value: TResEvalUInt; ErrorEl: TPasElement);
procedure SuccUInt(Value: TResEvalUInt; ErrorEl: TPasElement);
procedure PredString(Value: TResEvalString; ErrorEl: TPasElement);
procedure SuccString(Value: TResEvalString; ErrorEl: TPasElement);
procedure PredUnicodeString(Value: TResEvalUTF16; ErrorEl: TPasElement);
procedure SuccUnicodeString(Value: TResEvalUTF16; ErrorEl: TPasElement);
procedure PredEnum(Value: TResEvalEnum; ErrorEl: TPasElement);
procedure SuccEnum(Value: TResEvalEnum; ErrorEl: TPasElement);
function CreateResEvalInt(UInt: MaxPrecUInt): TResEvalValue; virtual;
public
constructor Create;
function Eval(Expr: TPasExpr; Flags: TResEvalFlags): TResEvalValue;
function IsInRange(Expr, RangeExpr: TPasExpr; EmitHints: boolean): boolean;
function IsConst(Expr: TPasExpr): boolean;
@ -463,9 +513,13 @@ type
PosEl: TPasElement); virtual;
procedure EmitRangeCheckConst(id: int64; const aValue: String;
MinVal, MaxVal: MaxPrecInt; PosEl: TPasElement);
function OrdValue(Value: TResEvalValue; ErrorEl: TPasElement): TResEvalInt; virtual;
procedure PredValue(Value: TResEvalValue; ErrorEl: TPasElement); virtual;
procedure SuccValue(Value: TResEvalValue; ErrorEl: TPasElement); virtual;
property OnLog: TPasResEvalLogHandler read FOnLog write FOnLog;
property OnEvalIdentifier: TPasResEvalIdentHandler read FOnEvalIdentifier write FOnEvalIdentifier;
property OnEvalParams: TPasResEvalParamsHandler read FOnEvalParams write FOnEvalParams;
property AllowedInts: TResEvalTypedInts read FAllowedInts write FAllowedInts;
end;
TResExprEvaluatorClass = class of TResExprEvaluator;
@ -869,7 +923,13 @@ begin
if TResEvalInt(Result).Int=0 then exit;
if Result.Element<>nil then
Result:=Result.Clone;
TResEvalInt(Result).Int:=-TResEvalInt(Result).Int;
if TResEvalInt(Result).Int=0 then exit;
if not (TResEvalInt(Result).Typed in reitAllSigned) then
begin
// switch to untyped
TResEvalInt(Result).Typed:=reitNone;
end;
TResEvalInt(Result).Int:=-TResEvalInt(Result).Int
end;
revkUInt:
begin
@ -897,7 +957,19 @@ begin
begin
if Result.Element<>nil then
Result:=Result.Clone;
TResEvalInt(Result).Int:=not TResEvalInt(Result).Int;
case TResEvalInt(Result).Typed of
reitByte: TResEvalInt(Result).Int:=not byte(TResEvalInt(Result).Int);
reitShortInt: TResEvalInt(Result).Int:=not shortint(TResEvalInt(Result).Int);
reitWord: TResEvalInt(Result).Int:=not word(TResEvalInt(Result).Int);
reitSmallInt: TResEvalInt(Result).Int:=not smallint(TResEvalInt(Result).Int);
reitUIntSingle: TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $3fffff;
reitIntSingle: TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $7fffff;
reitLongWord: TResEvalInt(Result).Int:=not longword(TResEvalInt(Result).Int);
reitLongInt: TResEvalInt(Result).Int:=not longint(TResEvalInt(Result).Int);
reitUIntDouble: TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $fffffffffffff;
reitIntDouble: TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $1fffffffffffff;
else TResEvalInt(Result).Int:=not TResEvalInt(Result).Int;
end;
end;
revkUInt:
begin
@ -1945,7 +2017,7 @@ begin
writeln('TResExprEvaluator.EvalArrayParams ');
{$ENDIF}
if refConst in Flags then
RaiseConstantExprExp(20170522173150,Expr);
RaiseConstantExprExp(20170522173151,Expr);
end;
function TResExprEvaluator.EvalFuncParams(Expr: TParamsExpr;
@ -1973,7 +2045,7 @@ begin
exit;
end;
if refConst in Flags then
RaiseConstantExprExp(20170522173150,Expr);
RaiseConstantExprExp(20170522173152,Expr);
end;
function TResExprEvaluator.ExprStringToOrd(Value: TResEvalValue;
@ -2187,6 +2259,12 @@ begin
Result:=TResEvalUInt.CreateValue(UInt);
end;
constructor TResExprEvaluator.Create;
begin
inherited Create;
FAllowedInts:=ReitDefaults;
end;
function TResExprEvaluator.Eval(Expr: TPasExpr; Flags: TResEvalFlags
): TResEvalValue;
var
@ -2203,7 +2281,7 @@ begin
exit;
end;
{$IFDEF VerbosePasResEval}
writeln('TPasResolver.Eval Expr=',GetObjName(Expr),' Flags=',dbgs(Flags));
writeln('TResExprEvaluator.Eval Expr=',GetObjName(Expr),' Flags=',dbgs(Flags));
{$ENDIF}
if refAutoConst in Flags then
begin
@ -2469,6 +2547,243 @@ begin
EmitRangeCheckConst(id,aValue,IntToStr(MinVal),IntToStr(MaxVal),PosEl);
end;
function TResExprEvaluator.OrdValue(Value: TResEvalValue; ErrorEl: TPasElement
): TResEvalInt;
begin
case Value.Kind of
revkBool:
if TResEvalBool(Value).B then
Result:=TResEvalInt.CreateValue(1)
else
Result:=TResEvalInt.CreateValue(0);
revkString:
if length(TResEvalString(Value).S)<>1 then
RaiseRangeCheck(20170624160128,ErrorEl)
else
Result:=TResEvalInt.CreateValue(ord(TResEvalString(Value).S[1]));
revkUnicodeString:
if length(TResEvalUTF16(Value).S)<>1 then
RaiseRangeCheck(20170624160129,ErrorEl)
else
Result:=TResEvalInt.CreateValue(ord(TResEvalUTF16(Value).S[1]));
revkEnum:
Result:=TResEvalInt.CreateValue(TResEvalEnum(Value).Index);
else
{$IFDEF VerbosePasResEval}
writeln('TResExprEvaluator.OrdValue ',Value.AsDebugString);
{$ENDIF}
RaiseNotYetImplemented(20170624155932,ErrorEl);
end;
end;
procedure TResExprEvaluator.PredValue(Value: TResEvalValue; ErrorEl: TPasElement
);
begin
case Value.Kind of
revkBool:
PredBool(TResEvalBool(Value),ErrorEl);
revkInt:
PredInt(TResEvalInt(Value),ErrorEl);
revkUInt:
PredUInt(TResEvalUInt(Value),ErrorEl);
revkString:
PredString(TResEvalString(Value),ErrorEl);
revkUnicodeString:
PredUnicodeString(TResEvalUTF16(Value),ErrorEl);
revkEnum:
PredEnum(TResEvalEnum(Value),ErrorEl);
else
{$IFDEF VerbosePasResEval}
writeln('TResExprEvaluator.PredValue ',Value.AsDebugString);
{$ENDIF}
ReleaseEvalValue(Value);
RaiseNotYetImplemented(20170624135738,ErrorEl);
end;
end;
procedure TResExprEvaluator.SuccValue(Value: TResEvalValue; ErrorEl: TPasElement
);
begin
case Value.Kind of
revkBool:
SuccBool(TResEvalBool(Value),ErrorEl);
revkInt:
SuccInt(TResEvalInt(Value),ErrorEl);
revkUInt:
SuccUInt(TResEvalUInt(Value),ErrorEl);
revkString:
SuccString(TResEvalString(Value),ErrorEl);
revkUnicodeString:
SuccUnicodeString(TResEvalUTF16(Value),ErrorEl);
revkEnum:
SuccEnum(TResEvalEnum(Value),ErrorEl);
else
{$IFDEF VerbosePasResEval}
writeln('TResExprEvaluator.SuccValue ',Value.AsDebugString);
{$ENDIF}
ReleaseEvalValue(Value);
RaiseNotYetImplemented(20170624151252,ErrorEl);
end;
end;
procedure TResExprEvaluator.PredBool(Value: TResEvalBool; ErrorEl: TPasElement);
begin
if Value.B=false then
EmitRangeCheckConst(20170624140251,Value.AsString,
'true','true',ErrorEl);
Value.B:=not Value.B;
end;
procedure TResExprEvaluator.SuccBool(Value: TResEvalBool; ErrorEl: TPasElement);
begin
if Value.B=true then
EmitRangeCheckConst(20170624142316,Value.AsString,
'false','false',ErrorEl);
Value.B:=not Value.B;
end;
procedure TResExprEvaluator.PredInt(Value: TResEvalInt; ErrorEl: TPasElement);
begin
if Value.Int=low(MaxPrecInt) then
begin
EmitRangeCheckConst(20170624142511,IntToStr(Value.Int),
IntToStr(succ(low(MaxPrecInt))),IntToStr(high(MaxPrecInt)),ErrorEl);
Value.Int:=high(Value.Int);
end
else
dec(Value.Int);
end;
procedure TResExprEvaluator.SuccInt(Value: TResEvalInt; ErrorEl: TPasElement);
begin
if Value.Int=high(MaxPrecInt) then
begin
EmitRangeCheckConst(20170624142920,IntToStr(Value.Int),
IntToStr(low(MaxPrecInt)),IntToStr(pred(high(MaxPrecInt))),ErrorEl);
Value.Int:=low(Value.Int);
end
else
inc(Value.Int);
end;
procedure TResExprEvaluator.PredUInt(Value: TResEvalUInt; ErrorEl: TPasElement);
begin
if Value.UInt=low(MaxPrecUInt) then
begin
EmitRangeCheckConst(20170624143122,IntToStr(Value.UInt),
IntToStr(succ(low(MaxPrecUInt))),IntToStr(high(MaxPrecUInt)),ErrorEl);
Value.UInt:=high(Value.UInt);
end
else
dec(Value.UInt);
end;
procedure TResExprEvaluator.SuccUInt(Value: TResEvalUInt; ErrorEl: TPasElement);
begin
if Value.UInt=high(MaxPrecUInt) then
begin
EmitRangeCheckConst(20170624142921,IntToStr(Value.UInt),
IntToStr(low(MaxPrecUInt)),IntToStr(pred(high(MaxPrecUInt))),ErrorEl);
Value.UInt:=low(Value.UInt);
end
else
inc(Value.UInt);
end;
procedure TResExprEvaluator.PredString(Value: TResEvalString;
ErrorEl: TPasElement);
begin
if length(Value.S)<>1 then
RaiseRangeCheck(20170624150138,ErrorEl);
if Value.S[1]=#0 then
begin
EmitRangeCheckConst(20170624150220,Value.AsString,'#1','#255',ErrorEl);
Value.S:=#255;
end
else
Value.S:=pred(Value.S[1]);
end;
procedure TResExprEvaluator.SuccString(Value: TResEvalString;
ErrorEl: TPasElement);
begin
if length(Value.S)<>1 then
RaiseRangeCheck(20170624150432,ErrorEl);
if Value.S[1]=#255 then
begin
EmitRangeCheckConst(20170624150441,Value.AsString,'#0','#254',ErrorEl);
Value.S:=#0;
end
else
Value.S:=succ(Value.S[1]);
end;
procedure TResExprEvaluator.PredUnicodeString(Value: TResEvalUTF16;
ErrorEl: TPasElement);
begin
if length(Value.S)<>1 then
RaiseRangeCheck(20170624150703,ErrorEl);
if Value.S[1]=#0 then
begin
EmitRangeCheckConst(20170624150710,Value.AsString,'#1','#65535',ErrorEl);
Value.S:=WideChar(#65535);
end
else
Value.S:=pred(Value.S[1]);
end;
procedure TResExprEvaluator.SuccUnicodeString(Value: TResEvalUTF16;
ErrorEl: TPasElement);
begin
if length(Value.S)<>1 then
RaiseRangeCheck(20170624150849,ErrorEl);
if Value.S[1]=#65535 then
begin
EmitRangeCheckConst(20170624150910,Value.AsString,'#0','#65534',ErrorEl);
Value.S:=#0;
end
else
Value.S:=succ(Value.S[1]);
end;
procedure TResExprEvaluator.PredEnum(Value: TResEvalEnum; ErrorEl: TPasElement);
var
EnumValue: TPasEnumValue;
EnumType: TPasEnumType;
begin
EnumValue:=Value.IdentEl as TPasEnumValue;
EnumType:=EnumValue.Parent as TPasEnumType;
if Value.Index<=0 then
begin
EmitRangeCheckConst(20170624144332,Value.AsString,
TPasEnumValue(EnumType.Values[Min(1,EnumType.Values.Count-1)]).Name,
TPasEnumValue(EnumType.Values[EnumType.Values.Count-1]).Name,ErrorEl);
Value.Index:=EnumType.Values.Count-1;
end
else
dec(Value.Index);
Value.IdentEl:=TPasEnumValue(EnumType.Values[Value.Index]);
end;
procedure TResExprEvaluator.SuccEnum(Value: TResEvalEnum; ErrorEl: TPasElement);
var
EnumValue: TPasEnumValue;
EnumType: TPasEnumType;
begin
EnumValue:=Value.IdentEl as TPasEnumValue;
EnumType:=EnumValue.Parent as TPasEnumType;
if Value.Index>=EnumType.Values.Count-1 then
begin
EmitRangeCheckConst(20170624145013,Value.AsString,
TPasEnumValue(EnumType.Values[0]).Name,
TPasEnumValue(EnumType.Values[Max(0,EnumType.Values.Count-2)]).Name,ErrorEl);
Value.Index:=0;
end
else
inc(Value.Index);
Value.IdentEl:=TPasEnumValue(EnumType.Values[Value.Index]);
end;
{ TResolveData }
procedure TResolveData.SetElement(AValue: TPasElement);
@ -2571,10 +2886,19 @@ begin
Int:=aValue;
end;
constructor TResEvalInt.CreateValue(const aValue: MaxPrecInt; aTyped: TResEvalTypedInt
);
begin
Create;
Int:=aValue;
Typed:=aTyped;
end;
function TResEvalInt.Clone: TResEvalValue;
begin
Result:=inherited Clone;
TResEvalInt(Result).Int:=Int;
TResEvalInt(Result).Typed:=Typed;
end;
function TResEvalInt.AsString: string;
@ -2582,6 +2906,29 @@ begin
Result:=IntToStr(Int);
end;
function TResEvalInt.AsDebugString: string;
begin
if Typed=reitNone then
Result:=inherited AsDebugString
else
begin
str(Kind,Result);
case Typed of
reitByte: Result:=Result+':byte';
reitShortInt: Result:=Result+':shortint';
reitWord: Result:=Result+':word';
reitSmallInt: Result:=Result+':smallint';
reitUIntSingle: Result:=Result+':uintsingle';
reitIntSingle: Result:=Result+':intsingle';
reitLongWord: Result:=Result+':longword';
reitLongInt: Result:=Result+':longint';
reitUIntDouble: Result:=Result+':uintdouble';
reitIntDouble: Result:=Result+':intdouble';
end;
Result:=Result+'='+AsString;
end;
end;
{ TResEvalFloat }
constructor TResEvalFloat.Create;

221
packages/fcl-passrc/src/pasresolver.pp
View File

@ -207,6 +207,9 @@ unit PasResolver;
{$mode objfpc}{$H+}
{$inline on}
{$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF}
{$IFOPT R+}{$DEFINE RangeCheckOn}{$ENDIF}
interface
uses
@ -361,14 +364,6 @@ const
'range..'
);
const
MinSafeIntCurrency = -922337203685477;
MaxSafeIntCurrency = 922337203685477;
MinSafeIntSingle = -16777216;
MaxSafeIntSingle = 16777216;
MinSafeIntDouble = -$10000000000000;
MaxSafeIntDouble = $fffffffffffff;
type
TResolverBuiltInProc = (
bfCustom,
@ -1093,6 +1088,7 @@ type
Expr: TPrimitiveExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
function OnExprEvalParams(Sender: TResExprEvaluator;
Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
function EvalBaseTypeCast(Params: TParamsExpr; bt: TResolverBaseType): TResEvalvalue;
function Eval(Expr: TPasExpr; Flags: TResEvalFlags; Store: boolean = true): TResEvalValue;
protected
// custom types (added by descendant resolvers)
@ -1140,6 +1136,8 @@ type
Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
procedure BI_Ord_OnGetCallResult(Proc: TResElDataBuiltInProc;
{%H-}Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
procedure BI_Ord_OnEval(Proc: TResElDataBuiltInProc;
Params: TParamsExpr; out Evaluated: TResEvalValue); virtual;
function BI_LowHigh_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
procedure BI_LowHigh_OnGetCallResult(Proc: TResElDataBuiltInProc;
@ -7333,22 +7331,56 @@ var
Decl: TPasElement;
C: TClass;
BaseTypeData: TResElDataBaseType;
ResolvedType: TPasResolverResult;
begin
Result:=nil;
if not (Expr.CustomData is TResolvedReference) then
RaiseNotYetImplemented(20170518203134,Expr);
Ref:=TResolvedReference(Expr.CustomData);
Decl:=Ref.Declaration;
{$IFDEF VerbosePasResEval}
writeln('TPasResolver.OnExprEvalIdentifier Value=',Expr.Value,' Decl=',GetObjName(Decl));
{$ENDIF}
C:=Decl.ClassType;
if C=TPasConst then
begin
if (TPasConst(Decl).Expr<>nil)
and (TPasConst(Decl).IsConst or (TPasConst(Decl).VarType=nil)) then
begin
Result:=fExprEvaluator.Eval(TPasConst(Decl).Expr,Flags);
if TPasConst(Decl).VarType<>nil then
begin
// typed const
ComputeElement(TPasConst(Decl).VarType,ResolvedType,[rcType]);
end
else
ResolvedType.BaseType:=btNone;
Result:=fExprEvaluator.Eval(TPasConst(Decl).Expr,Flags+[refConst]);
if Result<>nil then
begin
if (Result.Element<>nil) and (Result.Element<>TPasConst(Decl).Expr) then
Result:=Result.Clone;
Result.IdentEl:=Decl;
if TPasConst(Decl).VarType<>nil then
begin
// typed const
if Result.Kind=revkInt then
case ResolvedType.BaseType of
btByte: TResEvalInt(Result).Typed:=reitByte;
btShortInt: TResEvalInt(Result).Typed:=reitShortInt;
btWord: TResEvalInt(Result).Typed:=reitWord;
btSmallInt: TResEvalInt(Result).Typed:=reitSmallInt;
btUIntSingle: TResEvalInt(Result).Typed:=reitUIntSingle;
btIntSingle: TResEvalInt(Result).Typed:=reitIntSingle;
btLongWord: TResEvalInt(Result).Typed:=reitLongWord;
btLongint: TResEvalInt(Result).Typed:=reitLongInt;
btUIntDouble: TResEvalInt(Result).Typed:=reitUIntDouble;
btIntDouble: TResEvalInt(Result).Typed:=reitIntDouble;
btInt64: TResEvalInt(Result).Typed:=reitNone; // default
else
ReleaseEvalValue(Result);
RaiseNotYetImplemented(20170624181050,TPasConst(Decl).VarType);
end;
end;
exit;
end;
end;
@ -7423,6 +7455,7 @@ var
Decl: TPasElement;
C: TClass;
BuiltInProc: TResElDataBuiltInProc;
bt: TResolverBaseType;
begin
Result:=nil;
if Params.Value.CustomData is TResolvedReference then
@ -7438,19 +7471,137 @@ begin
if Decl.CustomData is TResElDataBuiltInProc then
begin
BuiltInProc:=TResElDataBuiltInProc(Decl.CustomData);
{$IFDEF VerbosePas2JS}
{$IFDEF VerbosePasResEval}
writeln('TPasResolver.OnExprEvalParams BuiltInProc ',Decl.Name,' ',ResolverBuiltInProcNames[BuiltInProc.BuiltIn]);
{$ENDIF}
case BuiltInProc.BuiltIn of
bfLength: BI_Length_OnEval(BuiltInProc,Params,Result);
bfOrd: BI_Ord_OnEval(BuiltInProc,Params,Result);
bfLow,bfHigh: BI_LowHigh_OnEval(BuiltInProc,Params,Result);
bfPred,bfSucc: BI_PredSucc_OnEval(BuiltInProc,Params,Result);
else
{$IFDEF VerbosePasResEval}
writeln('TPasResolver.OnExprEvalParams BuiltInProc ',Decl.Name,' ',ResolverBuiltInProcNames[BuiltInProc.BuiltIn]);
{$ENDIF}
RaiseNotYetImplemented(20170624192324,Params);
end;
{$IFDEF VerbosePasResEval}
if Result<>nil then
writeln('TPasResolver.OnExprEvalParams BuiltInProc ',Decl.Name,' ',ResolverBuiltInProcNames[BuiltInProc.BuiltIn],' Result=',Result.AsString)
else
writeln('TPasResolver.OnExprEvalParams BuiltInProc ',Decl.Name,' ',ResolverBuiltInProcNames[BuiltInProc.BuiltIn],' Result=nil');
{$ENDIF}
exit;
end
else if Decl.CustomData is TResElDataBaseType then
begin
// typecast to basetype
bt:=TResElDataBaseType(Decl.CustomData).BaseType;
Result:=EvalBaseTypeCast(Params,bt);
end;
{$IFDEF VerbosePasResEval}
writeln('TPasResolver.OnExprEvalParams BuiltInProc ',Decl.Name,' ',GetObjName(Decl.CustomData));
{$ENDIF}
end;
end;
if Flags=[] then ;
end;
function TPasResolver.EvalBaseTypeCast(Params: TParamsExpr;
bt: TResolverBaseType): TResEvalvalue;
var
Value: TResEvalValue;
Int: MaxPrecInt;
MinIntVal, MaxIntVal: int64;
begin
Result:=nil;
{$IFDEF VerbosePasResEval}
writeln('TPasResolver.EvalBaseTypeCast bt=',bt);
{$ENDIF}
Value:=Eval(Params.Params[0],[refAutoConst]);
if Value=nil then exit;
try
case Value.Kind of
revkInt:
begin
Int:=TResEvalInt(Value).Int;
if bt=btQWord then
begin
// int to qword
if (Int<0) then
fExprEvaluator.EmitRangeCheckConst(20170624195049,
Value.AsString,'0',IntToStr(High(qword)),Params);
{$R-}
Result:=TResEvalUInt.CreateValue(MaxPrecUInt(Int));
{$IFDEF RangeCheckOn}{$R+}{$ENDIF}
end
else if bt in (btAllInteger-[btQWord]) then
begin
// int to int
GetIntegerRange(bt,MinIntVal,MaxIntVal);
if (Int<MinIntVal) or (Int>MaxIntVal) then
begin
fExprEvaluator.EmitRangeCheckConst(20170624194534,
Value.AsString,MinIntVal,MaxIntVal,Params);
{$R-}
case bt of
btByte: Result:=TResEvalInt.CreateValue(byte(Int),reitByte);
btShortInt: Result:=TResEvalInt.CreateValue(shortint(Int),reitShortInt);// ToDo: negative
btWord: Result:=TResEvalInt.CreateValue(word(Int),reitWord);
btSmallInt: Result:=TResEvalInt.CreateValue(smallint(Int),reitSmallInt);// ToDo: negative
btUIntSingle: Result:=TResEvalInt.CreateValue(Int and MaskUIntSingle,reitUIntSingle);// ToDo: negative
btIntSingle: Result:=TResEvalInt.CreateValue(Int and MaskUIntSingle,reitIntSingle);// ToDo: negative
btLongWord: Result:=TResEvalInt.CreateValue(longword(Int),reitLongWord);
btLongint: Result:=TResEvalInt.CreateValue(longint(Int),reitLongInt);// ToDo: negative
btUIntDouble: Result:=TResEvalInt.CreateValue(Int and MaskUIntDouble,reitUIntDouble);// ToDo: negative
btIntDouble: Result:=TResEvalInt.CreateValue(Int and MaskUIntDouble,reitIntDouble);// ToDo: negative
btInt64: Result:=TResEvalInt.CreateValue(Int);
else
RaiseNotYetImplemented(20170624200109,Params);
end;
{$IFDEF RangeCheckOn}{$R+}{$ENDIF}
end
else
begin
{$R-}
case bt of
btByte: Result:=TResEvalInt.CreateValue(Int,reitByte);
btShortInt: Result:=TResEvalInt.CreateValue(Int,reitShortInt);
btWord: Result:=TResEvalInt.CreateValue(Int,reitWord);
btSmallInt: Result:=TResEvalInt.CreateValue(Int,reitSmallInt);
btUIntSingle: Result:=TResEvalInt.CreateValue(Int,reitUIntSingle);
btIntSingle: Result:=TResEvalInt.CreateValue(Int,reitIntSingle);
btLongWord: Result:=TResEvalInt.CreateValue(Int,reitLongWord);
btLongint: Result:=TResEvalInt.CreateValue(Int,reitLongInt);
btUIntDouble: Result:=TResEvalInt.CreateValue(Int,reitUIntDouble);
btIntDouble: Result:=TResEvalInt.CreateValue(Int,reitIntDouble);
btInt64: Result:=TResEvalInt.CreateValue(Int);
else
RaiseNotYetImplemented(20170624200109,Params);
end;
{$IFDEF RangeCheckOn}{$R+}{$ENDIF}
end;
exit;
end
else
begin
{$IFDEF VerbosePasResEval}
writeln('TPasResolver.OnExprEvalParams typecast int to ',bt);
{$ENDIF}
RaiseNotYetImplemented(20170624194308,Params);
end;
end;
else
{$IFDEF VerbosePasResEval}
writeln('TPasResolver.OnExprEvalParams typecast to ',bt);
{$ENDIF}
RaiseNotYetImplemented(20170624193436,Params);
end;
finally
ReleaseEvalValue(Value);
end;
end;
function TPasResolver.Eval(Expr: TPasExpr; Flags: TResEvalFlags;
Store: boolean): TResEvalValue;
// Important: Caller must free result if (Result<>nil) and (Result.Element=nil)
@ -7461,6 +7612,9 @@ begin
{$ENDIF}
Result:=fExprEvaluator.Eval(Expr,Flags);
if Result=nil then exit;
{$IFDEF VerbosePasResEval}
writeln('TPasResolver.Eval Result=',Result.AsString);
{$ENDIF}
if Store
and (Expr.CustomData=nil)
@ -7913,13 +8067,13 @@ begin
exit(cIncompatible);
Params:=TParamsExpr(Expr);
// first param: enum or char
// first param: bool, enum or char
Param:=Params.Params[0];
ComputeElement(Param,ParamResolved,[]);
Result:=cIncompatible;
if rrfReadable in ParamResolved.Flags then
begin
if ParamResolved.BaseType=btChar then
if ParamResolved.BaseType in (btAllBooleans+btAllChars) then
Result:=cExact
else if (ParamResolved.BaseType=btContext) and (ParamResolved.TypeEl is TPasEnumType) then
Result:=cExact;
@ -7933,7 +8087,25 @@ end;
procedure TPasResolver.BI_Ord_OnGetCallResult(Proc: TResElDataBuiltInProc;
Params: TParamsExpr; out ResolvedEl: TPasResolverResult);
begin
SetResolverIdentifier(ResolvedEl,btSmallInt,Proc.Proc,FBaseTypes[btSmallInt],[rrfReadable]);
SetResolverIdentifier(ResolvedEl,btLongint,Proc.Proc,FBaseTypes[btLongint],[rrfReadable]);
end;
procedure TPasResolver.BI_Ord_OnEval(Proc: TResElDataBuiltInProc;
Params: TParamsExpr; out Evaluated: TResEvalValue);
var
Param: TPasExpr;
Value: TResEvalValue;
begin
Evaluated:=nil;
Param:=Params.Params[0];
Value:=Eval(Param,[]);
if Value=nil then exit;
try
Evaluated:=fExprEvaluator.OrdValue(Value,Params);
finally
if Evaluated=nil then
ReleaseEvalValue(Value);
end;
end;
function TPasResolver.BI_LowHigh_OnGetCallCompatibility(
@ -8261,8 +8433,22 @@ end;
procedure TPasResolver.BI_PredSucc_OnEval(Proc: TResElDataBuiltInProc;
Params: TParamsExpr; out Evaluated: TResEvalValue);
var
Param: TPasExpr;
begin
//writeln('TPasResolver.BI_PredSucc_OnEval START');
Evaluated:=nil;
Param:=Params.Params[0];
Evaluated:=Eval(Param,[]);
//writeln('TPasResolver.BI_PredSucc_OnEval Param=',Evaluated<>nil);
if Evaluated=nil then exit;
//writeln('TPasResolver.BI_PredSucc_OnEval Param=',Evaluated.AsString);
if Evaluated.Element<>nil then
Evaluated:=Evaluated.Clone;
if Proc.BuiltIn=bfPred then
fExprEvaluator.PredValue(Evaluated,Params)
else
fExprEvaluator.SuccValue(Evaluated,Params);
end;
function TPasResolver.BI_Str_CheckParam(IsFunc: boolean; Param: TPasExpr;
@ -9447,7 +9633,8 @@ begin
@BI_Chr_OnGetCallCompatibility,@BI_Chr_OnGetCallResult,nil,nil,bfChr);
if bfOrd in TheBaseProcs then
AddBuiltInProc('Ord','function Ord(const Enum or Char): integer',
@BI_Ord_OnGetCallCompatibility,@BI_Ord_OnGetCallResult,nil,nil,bfOrd);
@BI_Ord_OnGetCallCompatibility,@BI_Ord_OnGetCallResult,
@BI_Ord_OnEval,nil,bfOrd);
if bfLow in TheBaseProcs then
AddBuiltInProc('Low','function Low(const array or ordinal): ordinal or integer',
@BI_LowHigh_OnGetCallCompatibility,@BI_LowHigh_OnGetCallResult,
@ -9459,11 +9646,11 @@ begin
if bfPred in TheBaseProcs then
AddBuiltInProc('Pred','function Pred(const ordinal): ordinal',
@BI_PredSucc_OnGetCallCompatibility,@BI_PredSucc_OnGetCallResult,
nil,nil,bfPred);
@BI_PredSucc_OnEval,nil,bfPred);
if bfSucc in TheBaseProcs then
AddBuiltInProc('Succ','function Succ(const ordinal): ordinal',
@BI_PredSucc_OnGetCallCompatibility,@BI_PredSucc_OnGetCallResult,
nil,nil,bfSucc);
@BI_PredSucc_OnEval,nil,bfSucc);
if bfStrProc in TheBaseProcs then
AddBuiltInProc('Str','procedure Str(const var; var String)',
@BI_StrProc_OnGetCallCompatibility,nil,nil,

5
packages/fcl-passrc/src/pasuseanalyzer.pas
View File

@ -50,10 +50,7 @@ interface
uses
Classes, SysUtils, AVL_Tree, PasTree, PScanner,
{$IFDEF VerbosePasAnalyzer}
PasResolveEval,
{$ENDIF}
PasResolver;
PasResolver, PasResolveEval;
const
nPAUnitNotUsed = 5023;

15
packages/fcl-passrc/src/paswrite.pp
View File

@ -215,7 +215,6 @@ procedure TPasWriter.WriteClass(AClass: TPasClassType);
var
i: Integer;
Member: TPasElement;
InterfacesListPrefix: string;
LastVisibility, CurVisibility: TPasMemberVisibility;
begin
PrepareDeclSection('type');
@ -228,19 +227,7 @@ begin
okInterface: wrt('interface');
end;
if Assigned(AClass.AncestorType) then
wrt('(' + AClass.AncestorType.Name);
if AClass.Interfaces.Count > 0 then
begin
if Assigned(AClass.AncestorType) then
InterfacesListPrefix:=', '
else
InterfacesListPrefix:='(';
wrt(InterfacesListPrefix + TPasType(AClass.Interfaces[0]).Name);
for i := 1 to AClass.Interfaces.Count - 1 do
wrt(', ' + TPasType(AClass.Interfaces[i]).Name);
end;
if Assigned(AClass.AncestorType) or (AClass.Interfaces.Count > 0) then
wrtln(')')
wrtln('(' + AClass.AncestorType.Name + ')')
else
wrtln;
IncIndent;

22
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -191,7 +191,7 @@ type
Procedure TestByteRangeFail;
Procedure TestCustomIntRangeFail;
Procedure TestConstIntOperators;
// ToDo: TestConstBitwiseOps 3 and not 2, 3 and not longword(2)
Procedure TestConstBitwiseOps;
Procedure TestConstBoolOperators;
// strings
@ -2243,6 +2243,25 @@ begin
' q:longword=not (5 or not 2);',
' r=low(word)+high(int64);',
' s=low(longint)+high(integer);',
' t=succ(2)+pred(2);',
'begin']);
ParseProgram;
CheckResolverUnexpectedHints;
end;
procedure TTestResolver.TestConstBitwiseOps;
begin
StartProgram(false);
Add([
'const',
' a=3;',
' b=not a;',
' c=not word(a);',
' d=1 shl 2;',
' e=13 shr 1;',
' f=13 and 5;',
' g=10 or 5;',
' h=5 xor 7;',
'begin']);
ParseProgram;
CheckResolverUnexpectedHints;
@ -2261,6 +2280,7 @@ begin
' f=a<>b;',
' g=low(boolean) or high(boolean);',
' h=succ(false) or pred(true);',
' i=ord(false)+ord(true);',
'begin']);
ParseProgram;
CheckResolverUnexpectedHints;