development/compilers/freepascal/rtl/objpas/typinfo.pp

   1 {
   2     $Id$
   3     This file is part of the Free Pascal run time library.
   4
   5     Copyright (c) 1999-2000 by Florian Klaempfl
   6     member of the Free Pascal development team
   7
   8     See the file COPYING.FPC, included in this distribution,
   9     for details about the copyright.
  10
  11     This program is distributed in the hope that it will be useful,
  12     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14
  15  **********************************************************************}
  16
  17 { This unit provides the same functionality as the TypInfo Unit }
  18 { of Delphi                                                     }
  19
  20 unit typinfo;
  21
  22   interface
  23
  24 {$MODE objfpc}
  25
  26   uses sysutils;
  27
  28
  29 // temporary types:
  30
  31     type
  32        PShortString =^ShortString;
  33        PByte        =^Byte;
  34        PWord        =^Word;
  35        PLongint     =^Longint;
  36        PBoolean     =^Boolean;
  37        PSingle      =^Single;
  38        PDouble      =^Double;
  39        PExtended    =^Extended;
  40        PComp        =^Comp;
  41 {$ifdef HASFIXED}
  42        PFixed16     =^Fixed16;
  43 {$endif HASFIXED}
  44        { Doesn't exist ?
  45        PFIxed32  = ^Fixed32;
  46        }
  47        Variant      = Pointer;
  48
  49 {$MINENUMSIZE 1   this saves a lot of memory }
  50        // if you change one of the following enumeration types
  51        // you have also to change the compiler in an appropriate way !
  52        TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,
  53                    tkFloat,tkSet,tkMethod,tkSString,tkLString,tkAString,
  54                    tkWString,tkVariant,tkArray,tkRecord,tkInterface,
  55                    tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord,
  56                    tkDynArray,tkInterfaceRaw);
  57
  58        TTOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong);
  59
  60        TFloatType = (ftSingle,ftDouble,ftExtended,ftComp,ftCurr,
  61                      ftFixed16,ftFixed32);
  62        TMethodKind = (mkProcedure,mkFunction,mkConstructor,mkDestructor,
  63                       mkClassProcedure, mkClassFunction);
  64        TParamFlags = set of (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut);
  65        TIntfFlags = set of (ifHasGuid,ifDispInterface,ifDispatch);
  66
  67 {$MINENUMSIZE DEFAULT}
  68
  69    const
  70       ptField = 0;
  71       ptStatic = 1;
  72       ptVirtual = 2;
  73       ptConst = 3;
  74
  75       tkString        = tkSString;
  76
  77    type
  78       TTypeKinds = set of TTypeKind;
  79
  80 {$PACKRECORDS 1}
  81       TTypeInfo = record
  82          Kind : TTypeKind;
  83          Name : ShortString;
  84          // here the type data follows as TTypeData record
  85       end;
  86
  87       PTypeInfo = ^TTypeInfo;
  88       PPTypeInfo = ^PTypeInfo;
  89
  90       PTypeData = ^TTypeData;
  91       TTypeData = packed record
  92          case TTypeKind of
  93             tkUnKnown,tkLString,tkWString,tkAString,tkVariant:
  94               ();
  95             tkInteger,tkChar,tkEnumeration,tkWChar:
  96               (OrdType : TTOrdType;
  97                case TTypeKind of
  98                   tkInteger,tkChar,tkEnumeration,tkBool,tkWChar : (
  99                     MinValue,MaxValue : Longint;
 100                     case TTypeKind of
 101                       tkEnumeration:
 102                         (
 103                         BaseType : PTypeInfo;
 104                         NameList : ShortString)
 105                     );
 106                   tkSet:
 107                     (CompType : PTypeInfo)
 108               );
 109             tkFloat:
 110               (FloatType : TFloatType);
 111             tkSString:
 112               (MaxLength : Byte);
 113             tkClass:
 114               (ClassType : TClass;
 115                ParentInfo : PTypeInfo;
 116                PropCount : SmallInt;
 117                UnitName : ShortString
 118                // here the properties follow as array of TPropInfo
 119               );
 120             tkMethod:
 121               (MethodKind : TMethodKind;
 122                ParamCount : Byte;
 123                ParamList : array[0..1023] of Char
 124              {in reality ParamList is a array[1..ParamCount] of:
 125                   record
 126                     Flags : TParamFlags;
 127                     ParamName : ShortString;
 128                     TypeName : ShortString;
 129                   end;
 130               followed by
 131                   ResultType : ShortString}
 132               );
 133             tkInt64:
 134               (MinInt64Value, MaxInt64Value: Int64);
 135             tkQWord:
 136               (MinQWordValue, MaxQWordValue: QWord);
 137             tkInterface:
 138               ({!!!!!!!}
 139               );
 140       end;
 141
 142       // unsed, just for completeness
 143       TPropData = packed record
 144         PropCount : Word;
 145         PropList : record end;
 146       end;
 147
 148       PPropInfo = ^TPropInfo;
 149       TPropInfo = packed record
 150         PropType : PTypeInfo;
 151         GetProc : Pointer;
 152         SetProc : Pointer;
 153         StoredProc : Pointer;
 154         Index : Integer;
 155         Default : Longint;
 156         NameIndex : SmallInt;
 157
 158         // contains the type of the Get/Set/Storedproc, see also ptxxx
 159         // bit 0..1 GetProc
 160         //     2..3 SetProc
 161         //     4..5 StoredProc
 162         //     6 : true, constant index property
 163         PropProcs : Byte;
 164
 165         Name : ShortString;
 166       end;
 167
 168       TProcInfoProc = procedure(PropInfo : PPropInfo) of object;
 169
 170       PPropList = ^TPropList;
 171       TPropList = array[0..65535] of PPropInfo;
 172
 173    const
 174       tkAny = [Low(TTypeKind)..High(TTypeKind)];
 175       tkMethods = [tkMethod];
 176       tkProperties = tkAny-tkMethods-[tkUnknown];
 177
 178     { general property handling }
 179     // just skips the id and the name
 180     function GetTypeData(TypeInfo : PTypeInfo) : PTypeData;
 181
 182     // searches in the property PropName
 183     function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo;
 184     procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
 185     function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds;
 186       PropList : PPropList) : Integer;
 187
 188     // returns true, if PropInfo is a stored property
 189     function IsStoredProp(Instance : TObject;PropInfo : PPropInfo) : Boolean;
 190
 191     { subroutines to read/write properties }
 192     function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Longint;
 193     procedure SetOrdProp(Instance : TObject;PropInfo : PPropInfo;
 194       Value : Longint);
 195
 196     function GetStrProp(Instance : TObject;PropInfo : PPropInfo) : Ansistring;
 197     procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo;
 198       const Value : Ansistring);
 199
 200     function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;
 201     procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo;
 202       Value : Extended);
 203
 204     function GetVariantProp(Instance : TObject;PropInfo : PPropInfo): Variant;
 205     procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo;
 206       const Value: Variant);
 207
 208     function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod;
 209     procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo;
 210       const Value : TMethod);
 211
 212     function GetInt64Prop(Instance: TObject; PropInfo: PPropInfo): Int64;
 213     procedure SetInt64Prop(Instance: TObject; PropInfo: PPropInfo;
 214       const Value: Int64);
 215
 216     { misc. stuff }
 217     function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
 218     function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
 219
 220
 221   const
 222     BooleanIdents: array[Boolean] of String = ('False', 'True');
 223     DotSep: String = '.';
 224
 225
 226   implementation
 227
 228   type
 229
 230     PMethod = ^TMethod;
 231
 232
 233 {$ASMMODE ATT}
 234
 235     function CallIntegerFunc(s: Pointer; Address: Pointer; Index, IValue: LongInt): Int64; assembler;
 236       asm
 237          movl S,%esi
 238          movl Address,%edi
 239          // ? Indexed function
 240          movl Index,%eax
 241          testl %eax,%eax
 242          je .LINoPush
 243          movl IValue,%eax
 244          pushl %eax
 245       .LINoPush:
 246          push %esi
 247          call %edi
 248          // now the result is in EDX:EAX
 249       end;
 250
 251     function CallIntegerProc(s : Pointer;Address : Pointer;Value : Integer; INdex,IValue : Longint) : Integer;assembler;
 252       asm
 253          movl S,%esi
 254          movl Address,%edi
 255          // Push value to set
 256          movl Value,%eax
 257          pushl %eax
 258          // ? Indexed procedure
 259          movl Index,%eax
 260          testl %eax,%eax
 261          je .LIPNoPush
 262          movl IValue,%eax
 263          pushl %eax
 264       .LIPNoPush:
 265          pushl %esi
 266          call %edi
 267       end;
 268
 269     function CallExtendedFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint) : Extended;assembler;
 270       asm
 271          movl S,%esi
 272          movl Address,%edi
 273          // ? Indexed function
 274          movl Index,%eax
 275          testl %eax,%eax
 276          je .LINoPush
 277          movl IValue,%eax
 278          pushl %eax
 279       .LINoPush:
 280          push %esi
 281          call %edi
 282          //
 283       end;
 284
 285     function CallExtendedProc(s : Pointer;Address : Pointer;Value : Extended; INdex,IVAlue : Longint) : Integer;assembler;
 286       asm
 287          movl S,%esi
 288          movl Address,%edi
 289          // Push value to set
 290          leal Value,%eax
 291          pushl (%eax)
 292          pushl 4(%eax)
 293          pushl 8(%eax)
 294          // ? Indexed procedure
 295          movl Index,%eax
 296          testl %eax,%eax
 297          je .LIPNoPush
 298          movl IValue,%eax
 299          pushl %eax
 300       .LIPNoPush:
 301          push %esi
 302          call %edi
 303       end;
 304
 305     function CallBooleanFunc(s : Pointer;Address : Pointer; Index,IValue : Longint) : Boolean;assembler;
 306       asm
 307          movl S,%esi
 308          movl Address,%edi
 309          // ? Indexed function
 310          movl Index,%eax
 311          testl %eax,%eax
 312          je .LBNoPush
 313          movl IValue,%eax
 314          pushl %eax
 315       .LBNoPush:
 316          push %esi
 317          call %edi
 318       end;
 319
 320     // Assembler functions can't have short stringreturn values.
 321     // So we make a procedure with var parameter.
 322     // That's not true (FK)
 323
 324     Procedure CallSStringFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint;
 325                             Var Res: Shortstring);assembler;
 326       asm
 327          movl S,%esi
 328          movl Address,%edi
 329          // ? Indexed function
 330          movl Index,%eax
 331          testl %eax,%eax
 332          jnz .LSSNoPush
 333          movl IValue,%eax
 334          pushl %eax
 335          // the result is stored in an invisible parameter
 336          pushl Res
 337       .LSSNoPush:
 338          push %esi
 339          call %edi
 340       end;
 341
 342     Procedure CallSStringProc(s : Pointer;Address : Pointer;Const Value : ShortString; INdex,IVAlue : Longint);assembler;
 343       asm
 344          movl S,%esi
 345          movl Address,%edi
 346          // Push value to set
 347          movl Value,%eax
 348          pushl %eax
 349          // ? Indexed procedure
 350          movl Index,%eax
 351          testl %eax,%eax
 352          // BUG 1 (jnz)
 353          je .LSSPNoPush
 354          movl IValue,%eax
 355          pushl %eax
 356       .LSSPNoPush:
 357          // BUG 2 (push)
 358          pushl %esi
 359          call %edi
 360       end;
 361
 362     function GetTypeData(TypeInfo : PTypeInfo) : PTypeData;
 363
 364       begin
 365          GetTypeData:=PTypeData(pointer(TypeInfo)+2+PByte(pointer(TypeInfo)+1)^);
 366       end;
 367
 368     function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo;
 369
 370       var
 371          hp : PTypeData;
 372          i : longint;
 373          p : string;
 374
 375       begin
 376          P:=UpCase(PropName);
 377          while Assigned(TypeInfo) do
 378            begin
 379               // skip the name
 380               hp:=GetTypeData(Typeinfo);
 381
 382               // the class info rtti the property rtti follows
 383               // immediatly
 384               Result:=PPropInfo(pointer(@hp^.UnitName)+Length(hp^.UnitName)+1+SizeOF(Word));
 385               for i:=1 to hp^.PropCount do
 386                 begin
 387                    // found a property of that name ?
 388                    if Upcase(Result^.Name)=P then
 389                      exit;
 390
 391                    // skip to next property
 392                    Result:=PPropInfo(pointer(@Result^.Name)+byte(Result^.Name[0])+1);
 393                 end;
 394               // parent class
 395               Typeinfo:=hp^.ParentInfo;
 396            end;
 397          Result:=Nil;
 398       end;
 399
 400     function IsStoredProp(Instance : TObject;PropInfo : PPropInfo) : Boolean;
 401
 402       begin
 403          case (PropInfo^.PropProcs shr 4) and 3 of
 404             ptfield:
 405               IsStoredProp:=PBoolean(Pointer(Instance)+Longint(PropInfo^.StoredProc))^;
 406             ptstatic:
 407               IsStoredProp:=CallBooleanFunc(Instance,PropInfo^.StoredProc,0,0);
 408             ptvirtual:
 409               IsStoredProp:=CallBooleanFunc(Instance,ppointer(Pointer(Instance.ClassType)+Longint(PropInfo^.StoredProc))^,0,0);
 410             ptconst:
 411               IsStoredProp:=LongBool(PropInfo^.StoredProc);
 412          end;
 413       end;
 414
 415     procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
 416       {
 417         Store Pointers to property information in the list pointed
 418         to by proplist. PRopList must contain enough space to hold ALL
 419         properties.
 420       }
 421       Type PWord = ^Word;
 422
 423       Var TD : PTypeData;
 424           TP : PPropInfo;
 425           Count : Longint;
 426
 427       begin
 428       TD:=GetTypeData(TypeInfo);
 429       // Get this objects TOTAL published properties count
 430       TP:=(@TD^.UnitName+Length(TD^.UnitName)+1);
 431       Count:=PWord(TP)^;
 432       // Now point TP to first propinfo record.
 433       Inc(Longint(TP),SizeOF(Word));
 434       While Count>0 do
 435         begin
 436         PropList^[0]:=TP;
 437         Inc(Longint(PropList),SizeOf(Pointer));
 438         // Point to TP next propinfo record.
 439         // Located at Name[Length(Name)+1] !
 440         TP:=PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+1);
 441         Dec(Count);
 442         end;
 443       // recursive call for parent info.
 444       If TD^.Parentinfo<>Nil then
 445         GetPropInfos (TD^.ParentInfo,PropList);
 446       end;
 447
 448     Procedure InsertProp (PL : PProplist;PI : PPropInfo; Count : longint);
 449
 450     VAr I : Longint;
 451
 452     begin
 453      I:=0;
 454      While (I<Count) and (PI^.Name>PL^[I]^.Name) do Inc(I);
 455      If I<Count then
 456        Move(PL^[I], PL^[I+1], (Count - I) * SizeOf(Pointer));
 457      PL^[I]:=PI;
 458     end;
 459
 460     function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds;
 461       PropList : PPropList) : Integer;
 462
 463       {
 464         Store Pointers to property information OF A CERTAIN KIND in the list pointed
 465         to by proplist. PRopList must contain enough space to hold ALL
 466         properties.
 467       }
 468       Var TempList : PPropList;
 469           PropInfo : PPropinfo;
 470           I,Count : longint;
 471
 472       begin
 473         Result:=0;
 474         Count:=GetTypeData(TypeInfo)^.Propcount;
 475         If Count>0 then
 476           begin
 477           GetMem(TempList,Count*SizeOf(Pointer));
 478           Try
 479             GetPropInfos(TypeInfo,TempList);
 480             For I:=0 to Count-1 do
 481               begin
 482               PropInfo:=TempList^[i];
 483               If PropInfo^.PropType^.Kind in TypeKinds then
 484                 begin
 485                 InsertProp(PropList,PropInfo,Result);
 486                 Inc(Result);
 487                 end;
 488               end;
 489           finally
 490             FreeMem(TempList,Count*SizeOf(Pointer));
 491           end;
 492           end;
 493       end;
 494
 495     Procedure SetIndexValues (P: PPRopInfo; Var Index,IValue : Longint);
 496
 497     begin
 498     Index:=((P^.PropProcs shr 6) and 1);
 499     If Index<>0 then
 500       IValue:=P^.Index
 501     else
 502       IValue:=0;
 503     end;
 504
 505     function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Longint;
 506
 507       var
 508          value,Index,Ivalue : longint;
 509          TypeInfo: PTypeInfo;
 510
 511       begin
 512          SetIndexValues(PropInfo,Index,Ivalue);
 513          case (PropInfo^.PropProcs) and 3 of
 514             ptfield:
 515               Value:=PLongint(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
 516             ptstatic:
 517               Value:=CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue);
 518             ptvirtual:
 519               Value:=CallIntegerFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue);
 520          end;
 521          { cut off unnecessary stuff }
 522          TypeInfo := PropInfo^.PropType;
 523          case TypeInfo^.Kind of
 524            tkChar, tkBool:
 525              Value:=Value and $ff;
 526            tkWChar:
 527              Value:=Value and $ffff;
 528            tkInteger:
 529              case GetTypeData(TypeInfo)^.OrdType of
 530                 otSWord,otUWord:
 531                   Value:=Value and $ffff;
 532                 otSByte,otUByte:
 533                   Value:=Value and $ff;
 534              end;
 535          end;
 536          GetOrdProp:=Value;
 537       end;
 538
 539     procedure SetOrdProp(Instance : TObject;PropInfo : PPropInfo;
 540       Value : Longint);
 541
 542       var
 543         Index,IValue : Longint;
 544         DataSize: Integer;
 545
 546       begin
 547          { cut off unnecessary stuff }
 548          case GetTypeData(PropInfo^.PropType)^.OrdType of
 549             otSWord,otUWord: begin
 550                 Value:=Value and $ffff;
 551                 DataSize := 2;
 552               end;
 553             otSByte,otUByte: begin
 554                 Value:=Value and $ff;
 555                 DataSize := 1;
 556             end;
 557            else DataSize := 4;
 558          end;
 559          SetIndexValues(PropInfo,Index,Ivalue);
 560          case (PropInfo^.PropProcs shr 2) and 3 of
 561             ptfield:
 562               case DataSize of
 563                 1: PByte(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Byte(Value);
 564                 2: PWord(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Word(Value);
 565                 4: PLongint(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
 566               end;
 567             ptstatic:
 568               CallIntegerProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
 569             ptvirtual:
 570               CallIntegerProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Value,Index,IValue);
 571          end;
 572       end;
 573
 574     function GetStrProp(Instance: TObject; PropInfo: PPropInfo): AnsiString;
 575     var
 576       Index, IValue: LongInt;
 577       ShortResult: ShortString;
 578     begin
 579       SetIndexValues(PropInfo, Index, IValue);
 580       case Propinfo^.PropType^.Kind of
 581         tkSString:
 582           case (PropInfo^.PropProcs) and 3 of
 583             ptField:
 584               Result := PShortString(Pointer(Instance) + LongWord(PropInfo^.GetProc))^;
 585             ptStatic:
 586               begin
 587                 CallSStringFunc(Instance, PropInfo^.GetProc, Index, IValue, ShortResult);
 588                 Result := ShortResult;
 589               end;
 590             ptVirtual:
 591               begin
 592                 CallSStringFunc(Instance, PPointer(Pointer(Instance.ClassType) +
 593                   LongWord(PropInfo^.GetProc))^, Index, IValue, ShortResult);
 594               Result := ShortResult;
 595             end;
 596           end;
 597         tkAString:
 598           case (PropInfo^.PropProcs) and 3 of
 599             ptField:
 600               Result := PAnsiString(Pointer(Instance) + LongWord(PropInfo^.GetProc))^;
 601             ptStatic:
 602               Pointer(Result) := Pointer(LongWord(CallIntegerFunc(Instance, PropInfo^.GetProc, Index, IValue)));
 603             ptVirtual:
 604               Pointer(Result) := Pointer(LongWord(CallIntegerFunc(Instance,
 605                 PPointer(Pointer(Instance.ClassType) + LongWord(PropInfo^.GetProc))^, Index, IValue)));
 606           end;
 607         else
 608           // Property is neither of type AnsiString nor of type ShortString
 609           SetLength(Result, 0);
 610       end;
 611     end;
 612
 613     procedure SetAStrProp(Instance : TObject;PropInfo : PPropInfo;
 614       const Value : AnsiString);
 615
 616       {
 617       Dirty trick based on fact that AnsiString is just a pointer,
 618       hence can be treated like an integer type.
 619       }
 620       var
 621          Index,Ivalue : Longint;
 622       begin
 623          SetIndexValues(PropInfo,Index,IValue);
 624          case (PropInfo^.PropProcs shr 2) and 3 of
 625             ptfield:
 626               PAnsiString(Pointer(Instance) + Longint(PropInfo^.SetProc))^ := Value;
 627             ptstatic:
 628               CallIntegerProc(Instance,PropInfo^.SetProc,Longint(Pointer(Value)),Index,IValue);
 629             ptvirtual:
 630               CallIntegerProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Longint(Pointer(Value)),Index,IValue);
 631          end;
 632       end;
 633
 634     procedure SetSStrProp(Instance : TObject;PropInfo : PPropInfo;
 635       const Value : ShortString);
 636
 637    Var Index,IValue: longint;
 638
 639     begin
 640       SetIndexValues(PRopInfo,Index,IValue);
 641          case (PropInfo^.PropProcs shr 2) and 3 of
 642             ptfield:
 643               PShortString(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
 644             ptstatic:
 645               CallSStringProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
 646             ptvirtual:
 647               CallSStringProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Value,Index,IValue);
 648          end;
 649     end;
 650
 651     procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo;
 652       const Value : AnsiString);
 653
 654       begin
 655       Case Propinfo^.PropType^.Kind of
 656         tkSString : SetSStrProp(Instance,PropInfo,Value);
 657         tkAString : SetAStrProp(Instance,Propinfo,Value);
 658       end;
 659       end;
 660
 661     function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;
 662
 663       var
 664          Index,Ivalue : longint;
 665          Value : Extended;
 666
 667
 668       begin
 669          SetIndexValues(PropInfo,Index,Ivalue);
 670          case (PropInfo^.PropProcs) and 3 of
 671             ptfield:
 672               Case GetTypeData(PropInfo^.PropType)^.FloatType of
 673                ftSingle:
 674                  Value:=PSingle(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
 675                ftDouble:
 676                  Value:=PDouble(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
 677                ftExtended:
 678                  Value:=PExtended(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
 679                ftcomp:
 680                  Value:=PComp(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
 681                { Uncommenting this code results in a internal error!!
 682                ftFixed16:
 683                  Value:=PFixed16(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
 684                ftfixed32:
 685                  Value:=PFixed32(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
 686                }
 687                end;
 688             ptstatic:
 689               Value:=CallExtendedFunc(Instance,PropInfo^.GetProc,Index,IValue);
 690             ptvirtual:
 691               Value:=CallExtendedFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue);
 692          end;
 693          Result:=Value;
 694       end;
 695
 696     procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo;
 697       Value : Extended);
 698
 699        Var IValue,Index : longint;
 700
 701        begin
 702          SetIndexValues(PropInfo,Index,Ivalue);
 703          case (PropInfo^.PropProcs shr 2) and 3 of
 704             ptfield:
 705               Case GetTypeData(PropInfo^.PropType)^.FloatType of
 706                ftSingle:
 707                  PSingle(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
 708                ftDouble:
 709                  PDouble(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
 710                ftExtended:
 711                  PExtended(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
 712                ftcomp:
 713                  PComp(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Comp(Value);
 714                { Uncommenting this code results in a internal error!!
 715                ftFixed16:
 716                  PFixed16(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
 717                ftfixed32:
 718                  PFixed32(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
 719                }
 720                end;
 721             ptstatic:
 722               CallExtendedProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
 723             ptvirtual:
 724               CallExtendedProc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,Value,Index,IValue);
 725          end;
 726       end;
 727
 728     function GetVariantProp(Instance : TObject;PropInfo : PPropInfo): Variant;
 729
 730       begin
 731          {!!!!!!!!!!!}
 732          Result:=nil;
 733       end;
 734
 735     procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo;
 736       const Value: Variant);
 737
 738       begin
 739          {!!!!!!!!!!!}
 740       end;
 741
 742     function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod;
 743
 744       var
 745          value: PMethod;
 746          Index,Ivalue : longint;
 747
 748       begin
 749          SetIndexValues(PropInfo,Index,Ivalue);
 750          case (PropInfo^.PropProcs) and 3 of
 751             ptfield:
 752               Value:=PMethod(Pointer(Instance)+Longint(PropInfo^.GetProc));
 753             ptstatic:
 754               Value:=PMethod(LongInt(CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue)));
 755             ptvirtual:
 756               Value:=PMethod(LongInt(CallIntegerFunc(Instance,PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^,Index,IValue)));
 757          end;
 758          GetMethodProp:=Value^;
 759       end;
 760
 761     procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo;
 762       const Value : TMethod);
 763
 764       var
 765         Index,IValue : Longint;
 766
 767       begin
 768          SetIndexValues(PropInfo,Index,Ivalue);
 769          case (PropInfo^.PropProcs shr 2) and 3 of
 770             ptfield:
 771               PMethod(Pointer(Instance)+Longint(PropInfo^.SetProc))^ := Value;
 772             ptstatic:
 773               CallIntegerProc(Instance,PropInfo^.SetProc,Integer(@Value), Index, IValue);
 774             ptvirtual:
 775               CallIntegerProc(Instance,
 776                 PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^,
 777                 Integer(@Value), Index, IValue);
 778          end;
 779       end;
 780
 781     function GetInt64Prop(Instance: TObject; PropInfo: PPropInfo): Int64;
 782     var
 783       Index, IValue: LongInt;
 784     begin
 785       SetIndexValues(PropInfo,Index,Ivalue);
 786       case PropInfo^.PropProcs and 3 of
 787         ptfield:
 788           Result := PInt64(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
 789         ptstatic:
 790           Result := CallIntegerFunc(Instance, PropInfo^.GetProc, Index, IValue);
 791         ptvirtual:
 792           Result := CallIntegerFunc(Instance,
 793             PPointer(Pointer(Instance.ClassType) + LongInt(PropInfo^.GetProc))^,
 794             Index, IValue);
 795       end;
 796     end;
 797
 798     procedure SetInt64Prop(Instance: TObject; PropInfo: PPropInfo;
 799       const Value: Int64);
 800     begin
 801       // !!!: Implement me!
 802     end;
 803
 804     function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
 805
 806       Var PS : PShortString;
 807           PT : PTypeData;
 808
 809       begin
 810        PT:=GetTypeData(TypeInfo);
 811        // ^.BaseType);
 812        //      If PT^.MinValue<0 then Value:=Ord(Value<>0); {map to 0/1}
 813        PS:=@PT^.NameList;
 814        While Value>0 Do
 815         begin
 816           PS:=PShortString(pointer(PS)+PByte(PS)^+1);
 817           Dec(Value);
 818         end;
 819        Result:=PS^;
 820       end;
 821
 822     function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
 823
 824       Var PS : PShortString;
 825           PT : PTypeData;
 826           Count : longint;
 827
 828       begin
 829         If Length(Name)=0 then exit(-1);
 830         PT:=GetTypeData(TypeInfo);
 831         Count:=0;
 832         Result:=-1;
 833         PS:=@PT^.NameList;
 834         While (Result=-1) and (PByte(PS)^<>0) do
 835           begin
 836           If CompareText(PS^, Name) = 0 then
 837             Result:=Count;
 838           PS:=PShortString(pointer(PS)+PByte(PS)^+1);
 839           Inc(Count);
 840           end;
 841       end;
 842
 843 end.
 844
 845 {
 846   $Log$
 847   Revision 1.1  2002/02/19 08:25:47  sasu
 848   Initial revision
 849
 850   Revision 1.1.2.6  2000/12/13 23:26:13  sg
 851   * Fixed typo in SetFloatProp
 852   * Rewrote GetStrProp, now all AnsiString will be correctly
 853     reference counted
 854
 855   Revision 1.1.2.5  2000/12/13 10:10:59  michael
 856   + Applied patch from Mattias Gaertner, bug 1273
 857
 858   Revision 1.1.2.4  2000/12/10 14:18:50  michael
 859   + Applied fix from Mattias Gaertner (bug 1288)
 860
 861   Revision 1.1.2.3  2000/12/03 21:58:53  peter
 862     * typekind is the same as 1.1
 863
 864   Revision 1.1.2.2  2000/11/25 18:34:00  sg
 865   * (Final) fix for AnsiString reference counter problem in SetStrProp
 866
 867   Revision 1.1.2.1  2000/07/17 07:10:29  sg
 868   * Fixed GetEnumValue (bug #1049, reported by Neil Graham)
 869
 870   Revision 1.1  2000/07/13 06:31:01  michael
 871   + Initial import
 872
 873   Revision 1.43  2000/06/29 08:47:13  sg
 874   * Bugfix for SetAStrProp (reference counter hasn't been increased)
 875   * Implemented GetInt64Prop
 876
 877   Revision 1.42  2000/06/22 20:02:51  peter
 878     * qword,int64 rtti support basics
 879
 880   Revision 1.41  2000/06/22 15:31:09  sg
 881   * Fixed a small typo in my previous update
 882
 883   Revision 1.40  2000/06/22 15:29:31  sg
 884   * Added prototypes for GetInt64Prop and SetInt64Prop
 885   * Added constants "BooleanIdents" and "DotSep"
 886
 887   Revision 1.39  2000/05/18 09:42:17  michael
 888   + GetPropInfo now case insensitive
 889
 890   Revision 1.38  2000/02/15 14:39:56  florian
 891     * disabled FIXED data type per default
 892
 893   Revision 1.37  2000/02/09 16:59:33  peter
 894     * truncated log
 895
 896   Revision 1.36  2000/01/07 16:41:44  daniel
 897     * copyright 2000
 898
 899   Revision 1.35  2000/01/07 16:32:29  daniel
 900     * copyright 2000 added
 901
 902   Revision 1.34  2000/01/06 01:08:33  sg
 903   * _This_ is the real revision 1.32... :-)
 904
 905   Revision 1.33  2000/01/06 00:23:24  pierre
 906    * missing declarations for otChar andotWChar added
 907
 908   Revision 1.32  2000/01/05 18:59:56  sg
 909   * Fixed missing () in InsertProp which caused memory corruptions
 910   * GetOrdProp handles Char and WChar now. (there are still some
 911     property types missing!)
 912
 913   Revision 1.31  1999/12/28 12:19:36  jonas
 914     * replaced "movl mem,%eax; xorl %eax,%eax" with "movl mem,%eax;
 915       testl %eax,%eax"
 916
 917   Revision 1.30  1999/11/06 14:41:31  peter
 918     * truncated log
 919
 920   Revision 1.29  1999/09/16 08:59:48  florian
 921     * GetPropInfo returns now nil if the property wasn't found
 922
 923   Revision 1.28  1999/09/15 20:27:24  florian
 924     + patch of Sebastion Guenther applied: Get/SetMethodProp implementation
 925
 926   Revision 1.27  1999/09/08 16:14:43  peter
 927     * pointer fixes
 928
 929   Revision 1.26  1999/09/03 15:39:23  michael
 930   * Fixes from Sebastian Guenther
 931
 932   Revision 1.25  1999/08/29 22:21:27  michael
 933   * Patch from Sebastian Guenther
 934
 935   Revision 1.24  1999/08/06 13:21:40  michael
 936   * Patch from Sebastian Guenther
 937
 938 }