From 0b02dab6841ed057a2c1d5ff1e10e528dbe73f60 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Fri, 11 Aug 2017 22:12:53 +0000 Subject: [PATCH] + new Delphi-compatible intrinsic GetTypeKind() which returns the TTypeKind of a type as a constant value (and thus can be optimized away in If- and Case-statements) + added test git-svn-id: trunk@36875 - --- .gitattributes | 1 + compiler/compinnr.pas | 1 + compiler/ninl.pas | 22 ++++++++++ compiler/pexpr.pas | 7 ++-- compiler/psystem.pas | 2 + compiler/symdef.pas | 1 + tests/test/trtti17.pp | 96 +++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 127 insertions(+), 3 deletions(-) create mode 100644 tests/test/trtti17.pp diff --git a/.gitattributes b/.gitattributes index 96ec9db366..c26824b963 100644 --- a/.gitattributes +++ b/.gitattributes @@ -13271,6 +13271,7 @@ tests/test/trtti13.pp svneol=native#text/pascal tests/test/trtti14.pp svneol=native#text/pascal tests/test/trtti15.pp svneol=native#text/pascal tests/test/trtti16.pp svneol=native#text/pascal +tests/test/trtti17.pp svneol=native#text/pascal tests/test/trtti2.pp svneol=native#text/plain tests/test/trtti3.pp svneol=native#text/plain tests/test/trtti4.pp svneol=native#text/plain diff --git a/compiler/compinnr.pas b/compiler/compinnr.pas index 5d4ee55990..fad18d34a3 100644 --- a/compiler/compinnr.pas +++ b/compiler/compinnr.pas @@ -112,6 +112,7 @@ type in_ror_assign_x_y = 93, in_neg_assign_x = 94, in_not_assign_x = 95, + in_gettypekind_x = 96, { Internal constant functions } in_const_sqr = 100, diff --git a/compiler/ninl.pas b/compiler/ninl.pas index 66506c069c..4045392ff4 100644 --- a/compiler/ninl.pas +++ b/compiler/ninl.pas @@ -3028,6 +3028,17 @@ implementation resultdef:=voidpointertype; end; + in_gettypekind_x: + 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; + in_assigned_x: begin { the parser has already made sure the expression is valid } @@ -3594,6 +3605,7 @@ implementation hp: tnode; shiftconst: longint; objdef: tobjectdef; + sym : tsym; begin result:=nil; @@ -3681,6 +3693,16 @@ implementation ); end; + in_gettypekind_x: + begin + sym:=tenumdef(typekindtype).int2enumsym(get_typekind(left.resultdef)); + if not assigned(sym) then + internalerror(2017081101); + if sym.typ<>enumsym then + internalerror(2017081102); + result:=genenumnode(tenumsym(sym)); + end; + in_assigned_x: begin result:=first_assigned; diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index ff8510b9b7..1fcf5cab87 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -472,9 +472,10 @@ implementation end; in_typeinfo_x, - in_objc_encode_x : + in_objc_encode_x, + in_gettypekind_x: begin - if (l=in_typeinfo_x) or + if (l in [in_typeinfo_x,in_gettypekind_x]) or (m_objectivec1 in current_settings.modeswitches) then begin consume(_LKLAMMER); @@ -493,7 +494,7 @@ implementation begin ttypenode(p1).allowed:=true; { allow helpers for TypeInfo } - if l=in_typeinfo_x then + if l in [in_typeinfo_x,in_gettypekind_x] then ttypenode(p1).helperallowed:=true; end; { else diff --git a/compiler/psystem.pas b/compiler/psystem.pas index 0357195768..aeb84ec6d5 100644 --- a/compiler/psystem.pas +++ b/compiler/psystem.pas @@ -106,6 +106,7 @@ implementation systemunit.insert(csyssym.create('SetString',in_setstring_x_y_z)); systemunit.insert(csyssym.create('Insert',in_insert_x_y_z)); systemunit.insert(csyssym.create('Delete',in_delete_x_y_z)); + systemunit.insert(csyssym.create('GetTypeKind',in_gettypekind_x)); systemunit.insert(cconstsym.create_ord('False',constord,0,pasbool8type)); systemunit.insert(cconstsym.create_ord('True',constord,1,pasbool8type)); end; @@ -679,6 +680,7 @@ implementation loadtype('methodpointer',methodpointertype); loadtype('nestedprocpointer',nestedprocpointertype); loadtype('HRESULT',hresultdef); + loadtype('TTYPEKIND',typekindtype); set_default_int_types; set_default_ptr_types; set_current_module(oldcurrentmodule); diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 7470dbf51b..213099ba02 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -1072,6 +1072,7 @@ interface methodpointertype, { typecasting of methodpointers to extract self } nestedprocpointertype, { typecasting of nestedprocpointers to extract parentfp } hresultdef, + typekindtype, { def of TTypeKind for correct handling of GetTypeKind parameters } { we use only one variant def for every variant class } cvarianttype, colevarianttype, diff --git a/tests/test/trtti17.pp b/tests/test/trtti17.pp new file mode 100644 index 0000000000..2bbe47274f --- /dev/null +++ b/tests/test/trtti17.pp @@ -0,0 +1,96 @@ +program trtti17; + +{$mode objfpc}{$H+} + +uses + typinfo, variants; + +type + TEvent = procedure of object; + + TTestObj = object + + end; + + TTestRec = record + + end; + + TArrayDyn = array of LongInt; + TArrayStatic = array[0..10] of LongInt; + + TSet = set of (alpha, beta, gamma); + +var + gError: LongInt = 0; + +function NextErrorCode: LongInt; inline; +begin + Inc(gError); + Result := gError; +end; + +procedure TestTypeInfo(aTypeInfo: PTypeInfo; aType: TTypeKind); +begin + if aTypeInfo^.Kind <> aType then begin + Writeln('TypeInfo failure; expected: ', aType, ', got: ', aTypeInfo^.Kind); + Halt(NextErrorCode); + end; +end; + +generic procedure TestTypeKind(aType: TTypeKind); inline; +begin + if GetTypeKind(T) <> aType then begin + Writeln('GetTypeKind() failure; expected: ', aType, ', got: ', GetTypeKind(T)); + Halt(NextErrorCode); + end; + TestTypeInfo(PTypeInfo(TypeInfo(T)), aType); +end; + +begin + specialize TestTypeKind(tkClass); + specialize TestTypeKind(tkClassRef); + specialize TestTypeKind(tkProcVar); + specialize TestTypeKind(tkMethod); + specialize TestTypeKind(tkInteger); + specialize TestTypeKind(tkInteger); + specialize TestTypeKind(tkInteger); + specialize TestTypeKind(tkInt64); + specialize TestTypeKind(tkInteger); + specialize TestTypeKind(tkInteger); + specialize TestTypeKind(tkInteger); + specialize TestTypeKind(tkQWord); + specialize TestTypeKind(tkObject); + specialize TestTypeKind(tkRecord); + specialize TestTypeKind(tkEnumeration); + specialize TestTypeKind(tkBool); + specialize TestTypeKind(tkBool); + specialize TestTypeKind(tkBool); + specialize TestTypeKind(tkBool); + specialize TestTypeKind(tkBool); + specialize TestTypeKind(tkBool); + specialize TestTypeKind(tkBool); + specialize TestTypeKind(tkBool); + specialize TestTypeKind(tkPointer); + specialize TestTypeKind(tkDynArray); + specialize TestTypeKind(tkArray); + specialize TestTypeKind(tkInterface); + specialize TestTypeKind(tkInterface); + specialize TestTypeKind(tkSString); + specialize TestTypeKind(tkAString); + specialize TestTypeKind(tkWString); + specialize TestTypeKind(tkUString); + specialize TestTypeKind(tkChar); + specialize TestTypeKind(tkWChar); + specialize TestTypeKind(tkWChar); + specialize TestTypeKind(tkFloat); + specialize TestTypeKind(tkFloat); + specialize TestTypeKind(tkFloat); + specialize TestTypeKind(tkFloat); + specialize TestTypeKind(tkInt64); + specialize TestTypeKind(tkSet); + specialize TestTypeKind(tkVariant); + {specialize TestTypeKind(tkFile); + specialize TestTypeKind(tkFile);} + Writeln('ok'); +end.