View Issue Details

IDProjectCategoryView StatusLast Update
0037251FPCCompilerpublic2020-06-26 12:44
ReporterBi0T1N Assigned ToSven Barth  
PrioritynormalSeverityminorReproducibilityalways
Status closedResolutionfixed 
Product Version3.3.1 
Fixed in Version3.3.1 
Summary0037251: [Patch] Add intrinsic IsConstValue function
DescriptionThis patch adds the IsConstValue intrinsic from Delphi as requested in 0028357.
Additional Informationhttps://stackoverflow.com/a/30417597
TagsNo tags attached.
Fixed in Revision45695
FPCOldBugId
FPCTarget-
Attached Files

Relationships

related to 0028357 new Intrinsic Compiler functions 

Activities

Bi0T1N

2020-06-24 22:55

reporter  

01-Add_IsConstValue_intrinsic.patch (2,732 bytes)   
diff --git compiler/compinnr.pas compiler/compinnr.pas
index f31a6477bf..7ffad4bda5 100644
--- compiler/compinnr.pas
+++ compiler/compinnr.pas
@@ -121,6 +121,7 @@ type
      in_faraddr_x         = 97,
      in_volatile_x        = 98,
      in_ismanagedtype_x   = 99,
+     in_isconstvalue_x    = 1000,
 
 { Internal constant functions }
      in_const_sqr        = 100,
diff --git compiler/ninl.pas compiler/ninl.pas
index 293330f634..d79c6069f7 100644
--- compiler/ninl.pas
+++ compiler/ninl.pas
@@ -3169,6 +3169,12 @@ implementation
                   resultdef:=pasbool1type;
                 end;
 
+              in_isconstvalue_x:
+                begin
+                  set_varstate(left,vs_read,[vsf_must_be_valid]);
+                  resultdef:=pasbool1type;
+                end;
+
               in_assigned_x:
                 begin
                   { the parser has already made sure the expression is valid }
@@ -3863,6 +3869,14 @@ implementation
                 result:=cordconstnode.create(0,resultdef,false);
             end;
 
+          in_isconstvalue_x:
+            begin
+              if is_constnode(left) then
+                result:=cordconstnode.create(1,resultdef,false)
+              else
+                result:=cordconstnode.create(0,resultdef,false);
+            end;
+
           in_assigned_x:
             begin
               result:=first_assigned;
diff --git compiler/pexpr.pas compiler/pexpr.pas
index 01a472f54a..bd23781756 100644
--- compiler/pexpr.pas
+++ compiler/pexpr.pas
@@ -524,6 +524,16 @@ implementation
                 end;
             end;
 
+          in_isconstvalue_x:
+            begin
+              consume(_LKLAMMER);
+              in_args:=true;
+              p1:=comp_expr([ef_accept_equal]);
+              consume(_RKLAMMER);
+              p2:=geninlinenode(l,false,p1);
+              statement_syssym:=p2;
+            end;
+
           in_aligned_x,
           in_unaligned_x,
           in_volatile_x:
diff --git compiler/psystem.pas compiler/psystem.pas
index b05cccdea0..326160cfba 100644
--- compiler/psystem.pas
+++ compiler/psystem.pas
@@ -112,6 +112,7 @@ implementation
         systemunit.insert(csyssym.create('Delete',in_delete_x_y_z));
         systemunit.insert(csyssym.create('GetTypeKind',in_gettypekind_x));
         systemunit.insert(csyssym.create('IsManagedType',in_ismanagedtype_x));
+        systemunit.insert(csyssym.create('IsConstValue',in_isconstvalue_x));
         systemunit.insert(csyssym.create('fpc_eh_return_data_regno', in_const_eh_return_data_regno));
         systemunit.insert(cconstsym.create_ord('False',constord,0,pasbool1type));
         systemunit.insert(cconstsym.create_ord('True',constord,1,pasbool1type));
tisconstvalue2.pp (1,140 bytes)   
program tisconstvalue2;

{$mode Delphi}

// example taken from https://stackoverflow.com/a/30417597

type
  TFlavor = (Tasty, Nasty);

  TIntegerHelper = record helper for Integer
  private
    function GetTastyPoint: Integer;
    function GetNastyPoint: Integer;
  public
    function GetSomething(Flavor: TFlavor): Integer; inline;
  end;

  function TIntegerHelper.GetTastyPoint: Integer;
  begin
    Result := 10;
  end;

  function TIntegerHelper.GetNastyPoint: Integer;
  begin
    Result := -10;
  end;

  function TIntegerHelper.GetSomething(Flavor: TFlavor): Integer;
  begin
    if IsConstValue(Flavor) then
    begin
      if Flavor = Tasty then
        Result := Self.GetTastyPoint
      else
        Result := Self.GetNastyPoint;
    end
    else
    begin
      Result := 0;
    end;
  end;

var
  i: Integer;
  n: TFlavor;

begin
  i := 100000.GetSomething(Tasty);
  if i <> 10 then
    Halt(1);

  n := Tasty;
  i := 100000.GetSomething(Nasty);
  if i <> -10 then
    Halt(2);

  i := 100000.GetSomething(n);
  if i <> 0 then
    Halt(3);

  Writeln('Ok');
end.
tisconstvalue2.pp (1,140 bytes)   
tisconstvalue1.pp (2,840 bytes)   
program tisconstvalue1;

{$mode objfpc}
{$modeswitch advancedrecords}

type
  TTestLongInt = record
    a: LongInt;
  end;

  TTestAnsiString = record
    a: AnsiString;
  end;
{
  TTestManaged = record
    a: LongInt;
    class operator Initialize(var aTestManaged: TTestManaged);
  end;

  class operator TTestManaged.Initialize(var aTestManaged: TTestManaged);
  begin
    aTestManaged.a := 42;
  end;
}
type
  TDynArrayLongInt = array of LongInt;
  TStaticArrayAnsiString = array[0..4] of AnsiString;

  TEnum = (eOne, eTwo, eThree);
  TSet = set of (sOne, sTwo, sThree);

const
  // untyped
  Number = 100;
  Str = 'Hello World!';
  Dbl = 1.1;
  NilPtr = nil;
  IsConst = True;
  GUID = '{10101010-1010-0101-1001-110110110110}';
  // typed
  IntConst: Integer = 13;
  RealConst: Real = 12;
  Alphabet: array [1..26] of char =
       ('A','B','C','D','E','F','G','H','I',
        'J','K','L','M','N','O','P','Q','R',
        'S','T','U','V','W','X','Y','Z');
  MyGUID: TGUID = '{10101010-1010-0101-1001-110110110110}';
  Bool: Boolean = False;

var
  l: LongInt;
  o: TObject;
  _as: AnsiString;
  lir: TTestLongInt;
  asr: TTestAnsiString;
  //mr: TTestManaged;
  liarr: TDynArrayLongInt;
  sasarr: TStaticArrayAnsiString;

begin
  l := 1;
  if IsConstValue(l) then
    Halt(1);

  o := TObject.Create;
  try
    if IsConstValue(o) then
      Halt(2);
  finally
    o.Free;
  end;

  _as := 'Hello World!';
  if IsConstValue(_as) then
    Halt(3);

  if not IsConstValue(eOne) then
    Halt(4);
  if not IsConstValue(eTwo) then
    Halt(5);
  if not IsConstValue(eThree) then
    Halt(6);

  if not IsConstValue(Number) then
    Halt(7);
  if not IsConstValue(Str) then
    Halt(8);

  lir.a := 5;
  if IsConstValue(lir) then
    Halt(9);

  asr.a := 'Hello World!';
  if IsConstValue(asr) then
    Halt(10);
{
  if IsConstValue(mr) then
    Halt(11);
}
  SetLength(liarr, 2);
  liarr[0] := 1;
  liarr[1] := 2;
  if IsConstValue(liarr) then
    Halt(12);

  sasarr[0] := 'Hell';
  sasarr[1] := 'o ';
  sasarr[2] := 'Wor';
  sasarr[3] := 'ld!';
  if IsConstValue(sasarr) then
    Halt(13);

  if not IsConstValue(sOne) then
    Halt(14);
  if not IsConstValue(sTwo) then
    Halt(15);
  if not IsConstValue(sThree) then
    Halt(16);

  if not IsConstValue(Dbl) then
    Halt(17);

  if not IsConstValue(NilPtr) then
    Halt(18);

  if not IsConstValue(IsConst) then
    Halt(19);

  if not IsConstValue(GUID) then
    Halt(20);

  if IsConstValue(IntConst) then
    Halt(21);

  if IsConstValue(RealConst) then
    Halt(22);

  if IsConstValue(Alphabet) then
    Halt(23);

  if IsConstValue(MyGUID) then
    Halt(24);

  if IsConstValue(Bool) then
    Halt(25);

  Writeln('Ok');
end.
tisconstvalue1.pp (2,840 bytes)   

Sven Barth

2020-06-24 23:30

manager   ~0123584

First of thank you for the work.

Some questions however (that you might need to answer by testing with Delphi):
- does it also work with function pointers or class types (class of xxx)?
- can you think of cases where it should not compile some expression?
- what if you pass a function? Or a property? Is it evaluated? (I would say no, but better safe than sorry ;) )

Bi0T1N

2020-06-25 12:02

reporter   ~0123590

Good point, some of your points I had tested but forgot to attach the third test file. I've extended it by some missing things but it should cover everything now.
The line with

TClassOf = class of TMyClass;

does also not compile in Delphi 10.3 (missing brackets) - or did you mean something different with class of?
tisconstvalue3.pp (2,334 bytes)   
program tisconstvalue3;

{$IFDEF FPC}
  {$mode Delphi}
{$ENDIF}

type
  TMyClass = class
  const
    PI = 3.14;
  private
    FNumber: Integer;
  public
    function DoMathAndReturn(const AValue: Integer): Integer;
  published
    property MyNumber: Integer read FNumber;
  end;

  TClassOf = class of TMyClass;

  function TMyClass.DoMathAndReturn(const AValue: Integer): Integer;
  begin
    Result := FNumber * 2;
  end;

function WorldCopy(AInput: String): String;
begin
  if IsConstValue(AInput) then
    Halt(9);

  Result := 'Hello ' + AInput;
end;

function WorldConst(const AInput: String): String;
begin
  if IsConstValue(AInput) then
    Halt(10);

  Result := 'Hello ' + AInput;
end;

function WorldVar(var AInput: String): String;
begin
  if IsConstValue(AInput) then
    Halt(11);

  Result := 'Hello ' + AInput;
end;

function WorldOut(out AInput: String): String;
begin
  AInput := 'Test';
  if IsConstValue(AInput) then
    Halt(12);

  Result := 'Hello ' + AInput;
end;

var
  MyClass: TMyClass;
  MyString: String;

begin
  if IsConstValue(TMyClass) then
    Halt(1);

  // Error: type identifier not allowed here
  //if IsConstValue(TClassOf) then
  //  Halt(2);

  MyClass := TMyClass.Create;
  try
    if IsConstValue(MyClass) then
      Halt(3);

    if IsConstValue(MyClass.MyNumber) then
      Halt(4);

    if not IsConstValue(MyClass.PI) then
      Halt(5);

    if IsConstValue(MyClass.DoMathAndReturn(5)) then
      Halt(6);

    if IsConstValue(@MyClass) then
      Halt(7);
  finally
    MyClass.Free;
  end;

  if IsConstValue(@WorldCopy) then
    Halt(8);

  WorldCopy('World');
  WorldConst('World');
  MyString := 'World';
  WorldVar(MyString);
  WorldOut(MyString);

  if IsConstValue(WorldCopy('World')) then
    Halt(13);

  if IsConstValue(MyString) then
    Halt(14);

  if IsConstValue(@MyString) then
    Halt(15);

  UniqueString(MyString);
  if IsConstValue(MyString) then
    Halt(16);

  if not IsConstValue('Hello') then
    Halt(17);

  if not IsConstValue(3.14) then
    Halt(17);

  if not IsConstValue(12345) then
    Halt(18);

  if not IsConstValue(5 <> 2) then
    Halt(19);

  if not IsConstValue(5 - 5 = 0) then
    Halt(20);

  Writeln('Ok');
end.
tisconstvalue3.pp (2,334 bytes)   

Sven Barth

2020-06-25 13:26

manager   ~0123591

Mostly. There is also the following construct:

const
  SomeClass: TClass = TSomeClass;


Though considering that this is a typed constant this would simply return false... (though one could argue if passing "TSomeClass" directly should be considered const...)

You can also add tests that shall not compile (e.g. the "IsConstValue(TClassOf)"). Prepend them with "{ %FAIL }" at the top. You can obviously only test a single usecase with each test. ;)

Bi0T1N

2020-06-25 15:52

reporter   ~0123594

Added - just apply the patch on top.
02-Enhancement_of_tests.patch (1,441 bytes)   
diff --git tests/test/tisconstvalue3.pp tests/test/tisconstvalue3.pp
index fadee2f69c..052cbcb225 100644
--- tests/test/tisconstvalue3.pp
+++ tests/test/tisconstvalue3.pp
@@ -60,14 +60,13 @@ var
   MyClass: TMyClass;
   MyString: String;
 
+const
+  SomeClass: TClass = TMyClass;
+
 begin
   if IsConstValue(TMyClass) then
     Halt(1);
 
-  // Error: type identifier not allowed here
-  //if IsConstValue(TClassOf) then
-  //  Halt(2);
-
   MyClass := TMyClass.Create;
   try
     if IsConstValue(MyClass) then
@@ -125,5 +124,8 @@ begin
   if not IsConstValue(5 - 5 = 0) then
     Halt(20);
 
+  if IsConstValue(SomeClass) then
+    Halt(21);
+
   Writeln('Ok');
 end.
diff --git tests/test/tisconstvalue4.pp tests/test/tisconstvalue4.pp
new file mode 100644
index 0000000000..907968faa9
--- /dev/null
+++ tests/test/tisconstvalue4.pp
@@ -0,0 +1,33 @@
+{ %FAIL }
+program tisconstvalue4;
+
+{$IFDEF FPC}
+  {$mode Delphi}
+{$ENDIF}
+
+type
+  TMyClass = class
+  const
+    PI = 3.14;
+  private
+    FNumber: Integer;
+  public
+    function DoMathAndReturn(const AValue: Integer): Integer;
+  published
+    property MyNumber: Integer read FNumber;
+  end;
+
+  TClassOf = class of TMyClass;
+
+  function TMyClass.DoMathAndReturn(const AValue: Integer): Integer;
+  begin
+    Result := FNumber * 2;
+  end;
+
+begin
+  // Error: type identifier not allowed here
+  if IsConstValue(TClassOf) then
+    Halt(1);
+
+  Writeln('Ok');
+end.
02-Enhancement_of_tests.patch (1,441 bytes)   

Sven Barth

2020-06-25 22:50

manager   ~0123596

I've applied your patches, thank you for your contribution!

Please note that enum values have to be ascending, thus I've moved in_isconstvalue_x further down to its rightful place.

Please test and close if okay.

Issue History

Date Modified Username Field Change
2020-06-24 22:55 Bi0T1N New Issue
2020-06-24 22:55 Bi0T1N File Added: 01-Add_IsConstValue_intrinsic.patch
2020-06-24 22:55 Bi0T1N File Added: tisconstvalue2.pp
2020-06-24 22:55 Bi0T1N File Added: tisconstvalue1.pp
2020-06-24 23:24 Sven Barth Relationship added related to 0028357
2020-06-24 23:30 Sven Barth Note Added: 0123584
2020-06-25 12:02 Bi0T1N Note Added: 0123590
2020-06-25 12:02 Bi0T1N File Added: tisconstvalue3.pp
2020-06-25 13:26 Sven Barth Note Added: 0123591
2020-06-25 15:52 Bi0T1N Note Added: 0123594
2020-06-25 15:52 Bi0T1N File Added: 02-Enhancement_of_tests.patch
2020-06-25 22:50 Sven Barth Assigned To => Sven Barth
2020-06-25 22:50 Sven Barth Status new => resolved
2020-06-25 22:50 Sven Barth Resolution open => fixed
2020-06-25 22:50 Sven Barth Fixed in Version => 3.3.1
2020-06-25 22:50 Sven Barth Fixed in Revision => 45695
2020-06-25 22:50 Sven Barth FPCTarget => -
2020-06-25 22:50 Sven Barth Note Added: 0123596
2020-06-26 12:44 Bi0T1N Status resolved => closed