+ 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

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

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,

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;

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

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);

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,

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<T>(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<TObject>(tkClass);
+  specialize TestTypeKind<TClass>(tkClassRef);
+  specialize TestTypeKind<TProcedure>(tkProcVar);
+  specialize TestTypeKind<TEvent>(tkMethod);
+  specialize TestTypeKind<Int8>(tkInteger);
+  specialize TestTypeKind<Int16>(tkInteger);
+  specialize TestTypeKind<Int32>(tkInteger);
+  specialize TestTypeKind<Int64>(tkInt64);
+  specialize TestTypeKind<UInt8>(tkInteger);
+  specialize TestTypeKind<UInt16>(tkInteger);
+  specialize TestTypeKind<UInt32>(tkInteger);
+  specialize TestTypeKind<UInt64>(tkQWord);
+  specialize TestTypeKind<TTestObj>(tkObject);
+  specialize TestTypeKind<TTestRec>(tkRecord);
+  specialize TestTypeKind<TTypeKind>(tkEnumeration);
+  specialize TestTypeKind<Boolean>(tkBool);
+  specialize TestTypeKind<Boolean16>(tkBool);
+  specialize TestTypeKind<Boolean32>(tkBool);
+  specialize TestTypeKind<Boolean64>(tkBool);
+  specialize TestTypeKind<ByteBool>(tkBool);
+  specialize TestTypeKind<WordBool>(tkBool);
+  specialize TestTypeKind<LongBool>(tkBool);
+  specialize TestTypeKind<QWordBool>(tkBool);
+  specialize TestTypeKind<Pointer>(tkPointer);
+  specialize TestTypeKind<TArrayDyn>(tkDynArray);
+  specialize TestTypeKind<TArrayStatic>(tkArray);
+  specialize TestTypeKind<IInterface>(tkInterface);
+  specialize TestTypeKind<IDispatch>(tkInterface);
+  specialize TestTypeKind<ShortString>(tkSString);
+  specialize TestTypeKind<AnsiString>(tkAString);
+  specialize TestTypeKind<WideString>(tkWString);
+  specialize TestTypeKind<UnicodeString>(tkUString);
+  specialize TestTypeKind<AnsiChar>(tkChar);
+  specialize TestTypeKind<WideChar>(tkWChar);
+  specialize TestTypeKind<UnicodeChar>(tkWChar);
+  specialize TestTypeKind<Single>(tkFloat);
+  specialize TestTypeKind<Double>(tkFloat);
+  specialize TestTypeKind<Extended>(tkFloat);
+  specialize TestTypeKind<Currency>(tkFloat);
+  specialize TestTypeKind<Comp>(tkInt64);
+  specialize TestTypeKind<TSet>(tkSet);
+  specialize TestTypeKind<Variant>(tkVariant);
+  {specialize TestTypeKind<file>(tkFile);
+  specialize TestTypeKind<TextFile>(tkFile);}
+  Writeln('ok');
+end.