[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