* 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 -
This commit is contained in:
svenbarth 2021-03-27 09:35:07 +00:00
parent 57e040cb82
commit ca7c775e36
6 changed files with 105 additions and 7 deletions

4
.gitattributes vendored
View File

@ -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

View File

@ -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
tests/test/trtti21.pp Normal file
View File

@ -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
tests/test/trtti22.pp Normal file
View File

@ -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
tests/test/trtti23.pp Normal file
View File

@ -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
tests/webtbs/tw38642.pp Normal file
View File

@ -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.