Explorar el Código

* fix for Mantis #38642: for enumerations with jumps Delphi behaves as follows:
- GetTypeKind returns tkEnumeration (FPC previously generated a compile error here)
- GetTypeInfo on a generic parameters returns Nil for such types (FPC previously generated a compile error here)
- GetTypeInfo otherwise generates a compile error (as before)

git-svn-id: trunk@49064 -

svenbarth hace 4 años
padre
commit
ca7c775e36
Se han modificado 6 ficheros con 105 adiciones y 7 borrados
  1. 4 0
      .gitattributes
  2. 17 7
      compiler/ninl.pas
  3. 26 0
      tests/test/trtti21.pp
  4. 17 0
      tests/test/trtti22.pp
  5. 27 0
      tests/test/trtti23.pp
  6. 14 0
      tests/webtbs/tw38642.pp

+ 4 - 0
.gitattributes

@@ -15848,6 +15848,9 @@ tests/test/trtti18b.pp svneol=native#text/pascal
 tests/test/trtti19.pp svneol=native#text/pascal
 tests/test/trtti2.pp svneol=native#text/plain
 tests/test/trtti20.pp svneol=native#text/pascal
+tests/test/trtti21.pp svneol=native#text/pascal
+tests/test/trtti22.pp svneol=native#text/pascal
+tests/test/trtti23.pp svneol=native#text/pascal
 tests/test/trtti3.pp svneol=native#text/plain
 tests/test/trtti4.pp svneol=native#text/plain
 tests/test/trtti5.pp svneol=native#text/plain
@@ -18757,6 +18760,7 @@ tests/webtbs/tw38549c.pp svneol=native#text/plain
 tests/webtbs/tw38549d.pp svneol=native#text/plain
 tests/webtbs/tw3863.pp svneol=native#text/plain
 tests/webtbs/tw3864.pp svneol=native#text/plain
+tests/webtbs/tw38642.pp svneol=native#text/pascal
 tests/webtbs/tw3865.pp svneol=native#text/plain
 tests/webtbs/tw3870.pp svneol=native#text/plain
 tests/webtbs/tw3893.pp svneol=native#text/plain

+ 17 - 7
compiler/ninl.pas

@@ -3209,7 +3209,11 @@ implementation
                   if target_info.system in systems_managed_vm then
                     message(parser_e_feature_unsupported_for_vm);
                    if (left.resultdef.typ=enumdef) and
-                      (tenumdef(left.resultdef).has_jumps) then
+                      (tenumdef(left.resultdef).has_jumps) and
+                      (
+                        (left.nodetype<>typen) or
+                        not (sp_generic_para in ttypenode(left).typesym.symoptions)
+                      ) then
                      CGMessage(type_e_no_type_info);
                    set_varstate(left,vs_read,[vsf_must_be_valid]);
                    resultdef:=voidpointertype;
@@ -3219,9 +3223,6 @@ implementation
                 begin
                   if target_info.system in systems_managed_vm then
                     message(parser_e_feature_unsupported_for_vm);
-                  if (left.resultdef.typ=enumdef) and
-                     (tenumdef(left.resultdef).has_jumps) then
-                    CGMessage(type_e_no_type_info);
                   set_varstate(left,vs_read,[vsf_must_be_valid]);
                   resultdef:=typekindtype;
                 end;
@@ -3935,9 +3936,18 @@ implementation
 
           in_typeinfo_x:
             begin
-              result:=caddrnode.create_internal(
-                crttinode.create(tstoreddef(left.resultdef),fullrtti,rdt_normal)
-              );
+              if (left.resultdef.typ=enumdef) and
+                 (tenumdef(left.resultdef).has_jumps) then
+                begin
+                  if (left.nodetype=typen) and (sp_generic_para in ttypenode(left).typesym.symoptions) then
+                    result:=cnilnode.create
+                  else
+                    internalerror(2021032601);
+                end
+              else
+                result:=caddrnode.create_internal(
+                  crttinode.create(tstoreddef(left.resultdef),fullrtti,rdt_normal)
+                );
             end;
 
           in_gettypekind_x:

+ 26 - 0
tests/test/trtti21.pp

@@ -0,0 +1,26 @@
+{ GetTypeKind() of an enumeration with holes returns tkEnumeration and
+  TypeInfo() returns Nil, but *only* inside a generic/specialization when used
+  with a generic parameter }
+
+program trtti21;
+
+{$mode objfpc}
+
+type
+  TEnum = (teOne = 1, teTwo);
+
+  generic TTest<T> = class
+    class function Test: Pointer;
+  end;
+
+class function TTest.Test: Pointer;
+begin
+  Result := TypeInfo(T);
+end;
+
+begin
+  if GetTypeKind(TEnum) <> tkEnumeration then
+    Halt(1);
+  if specialize TTest<TEnum>.Test <> Nil then
+    Halt(2);
+end.

+ 17 - 0
tests/test/trtti22.pp

@@ -0,0 +1,17 @@
+{ %FAIl }
+
+{ outside of generics TypeInfo() of types without type information (e.g. enums
+  with holes) throws a compile error }
+
+program trtti22;
+
+{$mode objfpc}
+
+type
+  TEnum = (teOne = 1, teTwo);
+
+var
+  p: Pointer;
+begin
+  p := TypeInfo(TEnum);
+end.

+ 27 - 0
tests/test/trtti23.pp

@@ -0,0 +1,27 @@
+{ %FAIl }
+
+{ inside of generics TypeInfo() of types without type information (e.g. enums
+  with holes) that are not generic parameters throws a compile error }
+
+program trtti23;
+
+{$mode objfpc}
+
+type
+  TEnum = (teOne = 1, teTwo);
+
+  generic TTest<T> = class
+    procedure Test;
+  end;
+
+{ TTest }
+
+procedure TTest.Test;
+var
+  ti: Pointer;
+begin
+  ti := TypeInfo(TEnum);
+end;
+
+begin
+end.

+ 14 - 0
tests/webtbs/tw38642.pp

@@ -0,0 +1,14 @@
+{ %NORUN }
+
+program tw38642;
+{$mode delphi}{$H+}
+uses
+  classes,
+  generics.collections;
+type
+  TMonthType = (January, February, May=10, June, July);
+  TMonthList = TList<TMonthType>;
+var
+  myList : TMonthList;
+begin
+end.