[fpc-devel] AS-IS for enums
Ondrej Pokorny
lazarus at kluug.net
Sun Mar 8 16:28:11 CET 2020
Hello Florian,
as we spoke I checked the patch for IS&AS operators for enumerations. I
also added int64/dword value compatibility that was missing in the last
patches.
There is still some bug/issue left. The objfpc mode shows warnings like
this:
test_as_is_1.lpr(51,8) Warning: Expectloc is not set in firstpass: calln
and the delphi mode crashes with an internal error 200306031.
I don't remember that this bug happened the last time I was working on
this. Could you please take a look at it?
I also added the check for enums with holes in objfpc mode that disables
the IS&AS operators there. It is marked with a ToDo comment. If you
decide to keep it there we need a new error message. If you decide to
delete it we don't need a new error message. I would personally delete
the extra check and enable AS&IS also for enums with holes (checking
only boundaries) but I don't care that much.
I attach the latest patch and a test program.
Thanks
Ondrej
-------------- next part --------------
program test_as_is_1;
{$define usedelphi}
{$ifdef usedelphi}
{$mode delphi}
{$else}
{$mode objfpc}
{$endif}
uses SysUtils;
type
TMyEnum = (zero, one, two);
TMyEnum2 = (zero2, one2, two2);
{$ifdef usedelphi}
TMyHoles = (zeroh, twoh = 2);
{$endif}
var
E: TMyEnum;
E2: TMyEnum2;
{$ifdef usedelphi}
H: TMyHoles;
{$endif}
I: Integer;
begin
// check a valid integer value agains an enum type
I := 1;
if I is TMyEnum then
E := I as TMyEnum
else
E := zero;
if E<>one then
Halt(1);
// check an invalid integer value agains an enum type
I := 5;
if I is TMyEnum then
Halt(2);
try
E := I as TMyEnum;
Halt(3);
except
E := one;
end;
// check an enum value against an enum type
E := one;
if E is TMyEnum2 then
E2 := E as TMyEnum2
else
E2 := zero2;
if E2<>one2 then
Halt(4);
// check a const enum value agaist an enum type
if one is TMyEnum2 then
E2 := one as TMyEnum2
else
E2 := zero2;
if E2<>one2 then
Halt(5);
// check an enum variable against the same enum type - is always true due to optimizations !!!
E := TMyEnum(-1);
if E is TMyEnum then
begin
if Ord(E) is TMyEnum then
Halt(7);
end else
Halt(8);
{$ifdef usedelphi}
// check an ord value agains an enum type with holes
I := 1;
if I is TMyHoles then // 1 is a valid value of TMyHoles in delphi mode
H := I as TMyHoles
else
H := zeroh;
if H<>TMyHoles(1) then
Halt(9);
{$endif}
Writeln('all good');
ReadLn;
end.
-------------- next part --------------
Index: compiler/ncnv.pas
===================================================================
--- compiler/ncnv.pas (revision 44280)
+++ compiler/ncnv.pas (working copy)
@@ -4376,6 +4376,20 @@
end;
end;
end
+ else if (right.resultdef.typ=enumdef) then
+ begin
+ { left must be an ordinal }
+ if not is_ordinal(left.resultdef) then
+ CGMessage1(type_e_ordinal_expr_expected,left.resultdef.typename);
+ case nodetype of
+ isn:
+ resultdef:=pasbool1type;
+ asn:
+ resultdef:=right.resultdef;
+ else
+ InternalError(2019070201);
+ end;
+ end
else
CGMessage1(type_e_class_or_interface_type_expected,right.resultdef.typename);
end;
@@ -4404,6 +4418,9 @@
procname: string;
statement : tstatementnode;
tempnode : ttempcreatenode;
+ v,res: Tconstexprint;
+ leftconv: tnode;
+ resulttype: tordtype;
begin
result:=nil;
{ Passing a class type to an "is" expression cannot result in a class
@@ -4449,6 +4466,61 @@
ccallparanode.create(left,ccallparanode.create(right,nil)),
resultdef);
end
+ else if (right.resultdef.typ=enumdef) then
+ begin
+ if tenumdef(right.resultdef).has_jumps and not (m_delphi in current_settings.modeswitches) then // ToDo: maybe delete this check to enable enums with holes in objfpc
+ Message(type_e_succ_and_pred_enums_with_assign_not_possible); // ToDo: new error message
+ if left.nodetype=ordconstn then
+ begin // 1 is TEnum: left is ordinal constant - do the check in compile-time
+ v:=Tordconstnode(left).value;
+ res.signed:=true;
+ res.overflow:=false;
+ res.svalue:=Ord((v>=tenumdef(right.resultdef).min) and (v<=tenumdef(right.resultdef).max));
+ result:=cordconstnode.create(res, resultdef, false);
+ end
+ else
+ if (left.resultdef.typ=enumdef) and (tenumdef(right.resultdef)=tenumdef(left.resultdef)) then
+ begin // the value is the same enumeration type - ignore the check
+ v:=Tordconstnode(left).value;
+ res.signed:=true;
+ res.overflow:=false;
+ res.svalue:=1; { true }
+ result:=cordconstnode.create(res, resultdef, false);
+ Message(type_w_comparison_always_true);
+ end
+ else
+ begin
+ case left.resultdef.typ of
+ enumdef:
+ begin
+ leftconv:=ctypeconvnode.create_internal(left, sinttype);
+ resulttype:=torddef(sinttype).ordtype;
+ end;
+ orddef:
+ begin
+ leftconv:=left;
+ resulttype:=torddef(leftconv.resultdef).ordtype;
+ end;
+ else
+ leftconv:=nil;
+ resulttype:=uvoid;
+ end;
+ case resulttype of
+ s8bit, s16bit, s32bit, u8bit, u16bit, pasbool1, pasbool8, pasbool16,
+ bool8bit, bool16bit: procname := 'fpc_do_is_enum';
+ u32bit, s64bit, pasbool32, bool32bit: procname := {$ifndef CPU64}'fpc_do_is_enum_int64'{$else}'fpc_do_is_enum'{$endif};
+ u64bit, pasbool64, bool64bit: procname := 'fpc_do_is_enum_qword';
+ else
+ Message(type_e_ordinal_expr_expected);
+ procname:='';
+ end;
+ result := ccallnode.createinternres(procname,
+ ccallparanode.create(cordconstnode.create(tenumdef(right.resultdef).max, sizesinttype, false),
+ ccallparanode.create(cordconstnode.create(tenumdef(right.resultdef).min, sizesinttype, false),
+ ccallparanode.create(leftconv, nil))),
+ resultdef);
+ end;
+ end
else
begin
if is_class(left.resultdef) then
@@ -4527,6 +4599,9 @@
function tasnode.pass_1 : tnode;
var
procname: string;
+ leftconv: tnode;
+ v: Tconstexprint;
+ resulttype: tordtype;
begin
result:=nil;
{ Passing a class type to an "as" expression cannot result in a class
@@ -4545,6 +4620,56 @@
call := ccallnode.createinternres('fpc_do_as',
ccallparanode.create(left,ccallparanode.create(right,nil)),
resultdef)
+ else if (right.resultdef.typ=enumdef) then
+ begin
+ if tenumdef(right.resultdef).has_jumps and not (m_delphi in current_settings.modeswitches) then // ToDo: maybe delete this check to enable enums with holes in objfpc
+ Message(type_e_succ_and_pred_enums_with_assign_not_possible); // ToDo: new error message
+ if left.nodetype=ordconstn then
+ begin // 1 as TEnum: left is ordinal constant - do the check in compile-time
+ v:=Tordconstnode(left).value;
+ if (v<tenumdef(right.resultdef).min) or (v>tenumdef(right.resultdef).max) then
+ Message(parser_e_range_check_error);
+ call := ctypeconvnode.create_internal(left, resultdef);
+ end
+ else
+ if (left.resultdef.typ=enumdef) and (tenumdef(right.resultdef)=tenumdef(left.resultdef)) then
+ begin // the value is the same enumeration type - ignore the check
+ call := left;
+ Message(parser_h_type_redef);
+ end
+ else
+ begin
+ case left.resultdef.typ of
+ enumdef:
+ begin
+ leftconv:=ctypeconvnode.create_internal(left, sizesinttype);
+ resulttype:=torddef(sizesinttype).ordtype;
+ end;
+ orddef:
+ begin
+ leftconv:=left;
+ resulttype:=torddef(leftconv.resultdef).ordtype;
+ end;
+ else
+ leftconv:=nil;
+ resulttype:=uvoid;
+ end;
+ case resulttype of
+ s8bit, s16bit, s32bit, u8bit, u16bit, pasbool1, pasbool8, pasbool16,
+ bool8bit, bool16bit: procname := 'fpc_do_as_enum';
+ u32bit, s64bit, pasbool32, bool32bit: procname := {$ifndef CPU64}'fpc_do_as_enum_int64'{$else}'fpc_do_as_enum'{$endif};
+ u64bit, pasbool64, bool64bit: procname := 'fpc_do_as_enum_qword';
+ else
+ CGMessage(type_e_ordinal_expr_expected);
+ procname := '';
+ end;
+ call := ccallnode.createinternres(procname,
+ ccallparanode.create(cordconstnode.create(tenumdef(right.resultdef).max, sizesinttype, false),
+ ccallparanode.create(cordconstnode.create(tenumdef(right.resultdef).min, sizesinttype, false),
+ ccallparanode.create(leftconv, nil))),
+ resultdef)
+ end;
+ end
else
begin
if is_class(left.resultdef) then
Index: rtl/inc/compproc.inc
===================================================================
--- rtl/inc/compproc.inc (revision 44280)
+++ rtl/inc/compproc.inc (working copy)
@@ -795,6 +795,13 @@
procedure fpc_AbstractErrorIntern;compilerproc;
procedure fpc_assert(Const Msg,FName:Shortstring;LineNo:Longint;ErrorAddr:Pointer); compilerproc;
+function fpc_do_as_enum(const value: SizeInt; const minvalue, maxvalue: SizeInt): SizeInt; compilerproc;
+function fpc_do_as_enum_int64(const value: Int64; const minvalue, maxvalue: SizeInt): SizeInt; compilerproc;
+function fpc_do_as_enum_qword(const value: QWord; const minvalue, maxvalue: SizeInt): SizeInt; compilerproc;
+function fpc_do_is_enum(const value: SizeInt; const minvalue, maxvalue: SizeInt): Boolean; compilerproc;
+function fpc_do_is_enum_int64(const value: int64; const minvalue, maxvalue: SizeInt): Boolean; compilerproc;
+function fpc_do_is_enum_qword(const value: QWord; const minvalue, maxvalue: SizeInt): Boolean; compilerproc;
+
{$ifdef FPC_HAS_FEATURE_FILEIO}
Procedure fpc_reset_typed(var f : TypedFile;Size : Longint); compilerproc;
Procedure fpc_rewrite_typed(var f : TypedFile;Size : Longint); compilerproc;
Index: rtl/inc/system.inc
===================================================================
--- rtl/inc/system.inc (revision 44280)
+++ rtl/inc/system.inc (working copy)
@@ -1605,6 +1605,54 @@
{*****************************************************************************
+ (I as TMyEnum) support.
+*****************************************************************************}
+
+function fpc_do_as_enum(const value: SizeInt; const minvalue, maxvalue: SizeInt): SizeInt; compilerproc; inline;
+begin
+ if fpc_do_is_enum(value, minvalue, maxvalue) then
+ result:=value
+ else
+ handleerroraddrframeInd(219,get_pc_addr,get_frame);
+end;
+
+function fpc_do_as_enum_int64(const value: Int64; const minvalue, maxvalue: SizeInt): SizeInt; compilerproc;
+begin
+ if fpc_do_is_enum_int64(value, minvalue, maxvalue) then
+ result:=SizeInt(value)
+ else
+ handleerroraddrframeInd(219,get_pc_addr,get_frame);
+end;
+
+function fpc_do_as_enum_qword(const value: QWord; const minvalue, maxvalue: SizeInt): SizeInt; compilerproc;
+begin
+ if fpc_do_is_enum_qword(value, minvalue, maxvalue) then
+ result:=SizeInt(value)
+ else
+ handleerroraddrframeInd(219,get_pc_addr,get_frame);
+end;
+
+
+{*****************************************************************************
+ (I is TMyEnum) support.
+*****************************************************************************}
+
+function fpc_do_is_enum(const value: SizeInt; const minvalue, maxvalue: SizeInt): Boolean; compilerproc;
+begin
+ result:=(value>=minvalue) and (value<=maxvalue);
+end;
+
+function fpc_do_is_enum_int64(const value: int64; const minvalue, maxvalue: SizeInt): Boolean; compilerproc;
+begin
+ result:=(value>=Low(SizeInt)) and (value<=High(SizeInt)) and (value>=minvalue) and (value<=maxvalue);
+end;
+
+function fpc_do_is_enum_qword(const value: QWord; const minvalue, maxvalue: SizeInt): Boolean; compilerproc;
+begin
+ result:=(value>=Low(SizeInt)) and (value<=High(SizeInt)) and (value>=minvalue) and (value<=maxvalue);
+end;
+
+{*****************************************************************************
SetJmp/LongJmp support.
*****************************************************************************}
More information about the fpc-devel
mailing list