typinfo.pp 25 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1998,99 by Florian Klaempfl
  5. member of the Free Pascal development team
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. { This unit provides the same functionality as the TypInfo Unit }
  13. { of Delphi }
  14. unit typinfo;
  15. interface
  16. {$MODE objfpc}
  17. // temporary types:
  18. type
  19. PShortString =^ShortString;
  20. PByte =^Byte;
  21. PLongint =^Longint;
  22. PBoolean =^Boolean;
  23. PSingle =^Single;
  24. PDouble =^Double;
  25. PExtended =^Extended;
  26. PComp =^Comp;
  27. PFixed16 =^Fixed16;
  28. { Doesn't exist ?
  29. PFIxed32 = ^Fixed32;
  30. }
  31. Variant = Pointer;
  32. TMethod = Pointer;
  33. {$MINENUMSIZE 1 this saves a lot of memory }
  34. // if you change one of the following enumeration types
  35. // you have also to change the compiler in an appropriate way !
  36. TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,
  37. tkFloat,tkSet,tkMethod,tkSString,tkLString,tkAString,
  38. tkWString,tkVariant,tkArray,tkRecord,tkInterface,
  39. tkClass,tkObject,tkWChar,tkBool);
  40. TTOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong);
  41. TFloatType = (ftSingle,ftDouble,ftExtended,ftComp,ftCurr,
  42. ftFixed16,ftFixed32);
  43. TMethodKind = (mkProcedure,mkFunction,mkSafeProcedure,mkSafeFunction);
  44. TParamFlags = set of (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut);
  45. TIntfFlags = set of (ifHasGuid,ifDispInterface,ifDispatch);
  46. {$MINENUMSIZE DEFAULT}
  47. const
  48. ptField = 0;
  49. ptStatic = 1;
  50. ptVirtual = 2;
  51. ptConst = 3;
  52. tkString = tkSString;
  53. type
  54. TTypeKinds = set of TTypeKind;
  55. {$PACKRECORDS 1}
  56. TTypeInfo = record
  57. Kind : TTypeKind;
  58. Name : ShortString;
  59. // here the type data follows as TTypeData record
  60. end;
  61. PTypeInfo = ^TTypeInfo;
  62. PPTypeInfo = ^PTypeInfo;
  63. PTypeData = ^TTypeData;
  64. TTypeData = packed record
  65. case TTypeKind of
  66. tkUnKnown,tkLString,tkWString,tkAString,tkVariant:
  67. ();
  68. tkInteger,tkChar,tkEnumeration,tkWChar:
  69. (OrdType : TTOrdType;
  70. case TTypeKind of
  71. tkInteger,tkChar,tkEnumeration,tkBool,tkWChar : (
  72. MinValue,MaxValue : Longint;
  73. case TTypeKind of
  74. tkEnumeration:
  75. (
  76. BaseType : PTypeInfo;
  77. NameList : ShortString)
  78. );
  79. tkSet:
  80. (CompType : PTypeInfo)
  81. );
  82. tkFloat:
  83. (FloatType : TFloatType);
  84. tkSString:
  85. (MaxLength : Byte);
  86. tkClass:
  87. (ClassType : TClass;
  88. ParentInfo : PTypeInfo;
  89. PropCount : SmallInt;
  90. UnitName : ShortString
  91. // here the properties follow as array of TPropInfo
  92. );
  93. tkMethod:
  94. ({!!!!!!!}
  95. );
  96. tkInterface:
  97. ({!!!!!!!}
  98. );
  99. end;
  100. // unsed, just for completeness
  101. TPropData = packed record
  102. PropCount : Word;
  103. PropList : record end;
  104. end;
  105. PPropInfo = ^TPropInfo;
  106. TPropInfo = packed record
  107. PropType : PTypeInfo;
  108. GetProc : Pointer;
  109. SetProc : Pointer;
  110. StoredProc : Pointer;
  111. Index : Integer;
  112. Default : Longint;
  113. NameIndex : SmallInt;
  114. // contains the type of the Get/Set/Storedproc, see also ptxxx
  115. // bit 0..1 GetProc
  116. // 2..3 SetProc
  117. // 4..5 StoredProc
  118. // 6 : true, constant index property
  119. PropProcs : Byte;
  120. Name : ShortString;
  121. end;
  122. TProcInfoProc = procedure(PropInfo : PPropInfo) of object;
  123. PPropList = ^TPropList;
  124. TPropList = array[0..65535] of PPropInfo;
  125. const
  126. tkAny = [Low(TTypeKind)..High(TTypeKind)];
  127. tkMethods = [tkMethod];
  128. tkProperties = tkAny-tkMethods-[tkUnknown];
  129. { general property handling }
  130. // just skips the id and the name
  131. function GetTypeData(TypeInfo : PTypeInfo) : PTypeData;
  132. // searches in the property PropName
  133. function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo;
  134. procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
  135. function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds;
  136. PropList : PPropList) : Integer;
  137. // returns true, if PropInfo is a stored property
  138. function IsStoredProp(Instance : TObject;PropInfo : PPropInfo) : Boolean;
  139. { subroutines to read/write properties }
  140. function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Longint;
  141. procedure SetOrdProp(Instance : TObject;PropInfo : PPropInfo;
  142. Value : Longint);
  143. function GetStrProp(Instance : TObject;PropInfo : PPropInfo) : Ansistring;
  144. procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo;
  145. const Value : Ansistring);
  146. function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;
  147. procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo;
  148. Value : Extended);
  149. function GetVariantProp(Instance : TObject;PropInfo : PPropInfo): Variant;
  150. procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo;
  151. const Value: Variant);
  152. function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod;
  153. procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo;
  154. const Value : TMethod);
  155. { misc. stuff }
  156. function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
  157. function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
  158. implementation
  159. {$ASMMODE ATT}
  160. function CallIntegerFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint) : Integer;assembler;
  161. asm
  162. movl S,%esi
  163. movl Address,%edi
  164. // ? Indexed function
  165. movl Index,%eax
  166. xorl %eax,%eax
  167. jnz .LINoPush
  168. movl IValue,%eax
  169. pushl %eax
  170. .LINoPush:
  171. call %edi
  172. // now the result is in EAX
  173. end;
  174. function CallIntegerProc(s : Pointer;Address : Pointer;Value : Integer; INdex,IVAlue : Longint) : Integer;assembler;
  175. asm
  176. movl S,%esi
  177. movl Address,%edi
  178. // Push value to set
  179. movl Value,%eax
  180. pushl %eax
  181. // ? Indexed procedure
  182. movl Index,%eax
  183. xorl %eax,%eax
  184. jnz .LIPNoPush
  185. movl IValue,%eax
  186. pushl %eax
  187. .LIPNoPush:
  188. call %edi
  189. end;
  190. function CallExtendedFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint) : Extended;assembler;
  191. asm
  192. movl S,%esi
  193. movl Address,%edi
  194. // ? Indexed function
  195. movl Index,%eax
  196. xorl %eax,%eax
  197. jnz .LINoPush
  198. movl IValue,%eax
  199. pushl %eax
  200. .LINoPush:
  201. call %edi
  202. //
  203. end;
  204. function CallExtendedProc(s : Pointer;Address : Pointer;Value : Extended; INdex,IVAlue : Longint) : Integer;assembler;
  205. asm
  206. movl S,%esi
  207. movl Address,%edi
  208. // Push value to set
  209. leal Value,%eax
  210. pushl (%eax)
  211. pushl 4(%eax)
  212. pushl 8(%eax)
  213. // ? Indexed procedure
  214. movl Index,%eax
  215. xorl %eax,%eax
  216. jnz .LIPNoPush
  217. movl IValue,%eax
  218. pushl %eax
  219. .LIPNoPush:
  220. call %edi
  221. end;
  222. function CallBooleanFunc(s : Pointer;Address : Pointer; Index,IValue : Longint) : Boolean;assembler;
  223. asm
  224. movl S,%esi
  225. movl Address,%edi
  226. // ? Indexed function
  227. movl Index,%eax
  228. xorl %eax,%eax
  229. jnz .LBNoPush
  230. movl IValue,%eax
  231. pushl %eax
  232. .LBNoPush:
  233. call %edi
  234. end;
  235. // Assembler functions can't have short stringreturn values.
  236. // So we make a procedure with var parameter.
  237. // That's not true (FK)
  238. Procedure CallSStringFunc(s : Pointer;Address : Pointer; INdex,IValue : Longint;
  239. Var Res: Shortstring);assembler;
  240. asm
  241. movl S,%esi
  242. movl Address,%edi
  243. // ? Indexed function
  244. movl Index,%eax
  245. xorl %eax,%eax
  246. jnz .LSSNoPush
  247. movl IValue,%eax
  248. pushl %eax
  249. // the result is stored in an invisible parameter
  250. pushl Res
  251. .LSSNoPush:
  252. call %edi
  253. end;
  254. Procedure CallSStringProc(s : Pointer;Address : Pointer;Const Value : ShortString; INdex,IVAlue : Longint);assembler;
  255. asm
  256. movl S,%esi
  257. movl Address,%edi
  258. // Push value to set
  259. movl Value,%eax
  260. pushl %eax
  261. // ? Indexed procedure
  262. movl Index,%eax
  263. xorl %eax,%eax
  264. jnz .LSSPNoPush
  265. movl IValue,%eax
  266. pushl %eax
  267. .LSSPNoPush:
  268. call %edi
  269. end;
  270. function GetTypeData(TypeInfo : PTypeInfo) : PTypeData;
  271. begin
  272. GetTypeData:=PTypeData(TypeInfo)+2+PByte(TypeInfo+1)^;
  273. end;
  274. function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo;
  275. var
  276. hp : PTypeData;
  277. i : longint;
  278. begin
  279. Result:=Nil;
  280. while Assigned(TypeInfo) do
  281. begin
  282. // skip the name
  283. hp:=GetTypeData(Typeinfo);
  284. // the class info rtti the property rtti follows
  285. // immediatly
  286. Result:=PPropInfo(@hp^.UnitName)+Length(hp^.UnitName)+1+SizeOF(Word);
  287. for i:=1 to hp^.PropCount do
  288. begin
  289. // found a property of that name ?
  290. if Result^.Name=PropName then
  291. exit;
  292. // skip to next property
  293. Result:=PPropInfo(@Result^.Name)+byte(Result^.Name[0])+1;
  294. end;
  295. // parent class
  296. Typeinfo:=hp^.ParentInfo;
  297. end;
  298. end;
  299. function IsStoredProp(Instance : TObject;PropInfo : PPropInfo) : Boolean;
  300. begin
  301. case (PropInfo^.PropProcs shr 4) and 3 of
  302. ptfield:
  303. IsStoredProp:=PBoolean(Pointer(Instance)+Longint(PropInfo^.StoredProc))^;
  304. ptstatic:
  305. IsStoredProp:=CallBooleanFunc(Instance,PropInfo^.StoredProc,0,0);
  306. ptvirtual:
  307. IsStoredProp:=CallBooleanFunc(Instance,(PPointer(Instance.ClassType)+Longint(PropInfo^.StoredProc)),0,0);
  308. ptconst:
  309. IsStoredProp:=LongBool(PropInfo^.StoredProc);
  310. end;
  311. end;
  312. procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
  313. {
  314. Store Pointers to property information in the list pointed
  315. to by proplist. PRopList must contain enough space to hold ALL
  316. properties.
  317. }
  318. Type PWord = ^Word;
  319. Var TD : PTypeData;
  320. TP : PPropInfo;
  321. Count : Longint;
  322. begin
  323. TD:=GetTypeData(TypeInfo);
  324. // Get this objects TOTAL published properties count
  325. TP:=(@TD^.UnitName+Length(TD^.UnitName)+1);
  326. Count:=PWord(TP)^;
  327. // Now point TP to first propinfo record.
  328. Inc(Longint(TP),SizeOF(Word));
  329. While Count>0 do
  330. begin
  331. PropList^[0]:=TP;
  332. Inc(Longint(PropList),SizeOf(Pointer));
  333. // Point to TP next propinfo record.
  334. // Located at Name[Length(Name)+1] !
  335. TP:=PPropInfo((@TP^.Name)+PByte(@TP^.Name)^+1);
  336. Dec(Count);
  337. end;
  338. // recursive call for parent info.
  339. If TD^.Parentinfo<>Nil then
  340. GetPropInfos (TD^.ParentInfo,PropList);
  341. end;
  342. Procedure InsertProp (PL : PProplist;PI : PPropInfo; Count : longint);
  343. VAr I : Longint;
  344. begin
  345. I:=0;
  346. While (I<Count) and (PI^.Name>PL^[I]^.Name) do Inc(I);
  347. If I<Count then
  348. Move(PL^[I],PL[I+1],Count-I*SizeOf(Pointer));
  349. PL^[I]:=PI;
  350. end;
  351. function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds;
  352. PropList : PPropList) : Integer;
  353. {
  354. Store Pointers to property information OF A CERTAIN KIND in the list pointed
  355. to by proplist. PRopList must contain enough space to hold ALL
  356. properties.
  357. }
  358. Var TempList : PPropList;
  359. PropInfo : PPropinfo;
  360. I,Count : longint;
  361. begin
  362. Result:=0;
  363. Count:=GetTypeData(TypeInfo)^.Propcount;
  364. If Count>0 then
  365. begin
  366. GetMem(TempList,Count*SizeOf(Pointer));
  367. Try
  368. GetPropInfos(TypeInfo,TempList);
  369. For I:=0 to Count-1 do
  370. begin
  371. PropInfo:=TempList^[i];
  372. If PropInfo^.PropType^.Kind in TypeKinds then
  373. begin
  374. InsertProp(PropList,PropInfo,Result);
  375. Inc(Result);
  376. end;
  377. end;
  378. finally
  379. FreeMem(TempList,Count*SizeOf(Pointer));
  380. end;
  381. end;
  382. end;
  383. Procedure SetIndexValues (P: PPRopInfo; Var Index,IValue : Longint);
  384. begin
  385. Index:=((P^.PropProcs shr 6) and 1);
  386. If Index=0 then
  387. IValue:=P^.Index
  388. else
  389. IValue:=0;
  390. end;
  391. function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Longint;
  392. var
  393. value,Index,Ivalue : longint;
  394. begin
  395. SetIndexValues(PropInfo,Index,Ivalue);
  396. case (PropInfo^.PropProcs) and 3 of
  397. ptfield:
  398. Value:=PLongint(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  399. ptstatic:
  400. Value:=CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue);
  401. ptvirtual:
  402. Value:=CallIntegerFunc(Instance,
  403. (PPointer(Instance.ClassType)+Longint(PropInfo^.GetProc)),
  404. Index,IValue);
  405. end;
  406. { cut off unnecessary stuff }
  407. case GetTypeData(PropInfo^.PropType)^.OrdType of
  408. otSWord,otUWord:
  409. Value:=Value and $ffff;
  410. otSByte,otUByte:
  411. Value:=Value and $ff;
  412. end;
  413. GetOrdProp:=Value;
  414. end;
  415. procedure SetOrdProp(Instance : TObject;PropInfo : PPropInfo;
  416. Value : Longint);
  417. Var Index,IValue : Longint;
  418. begin
  419. { cut off unnecessary stuff }
  420. case GetTypeData(PropInfo^.PropType)^.OrdType of
  421. otSWord,otUWord:
  422. Value:=Value and $ffff;
  423. otSByte,otUByte:
  424. Value:=Value and $ff;
  425. end;
  426. SetIndexValues(PropInfo,Index,Ivalue);
  427. case (PropInfo^.PropProcs) and 3 of
  428. ptfield:
  429. PLongint(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
  430. ptstatic:
  431. CallIntegerProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
  432. ptvirtual:
  433. CallIntegerProc(Instance,
  434. (PPointer(Instance.ClassType)+Longint(PropInfo^.SetProc)),
  435. Value,Index,IValue);
  436. end;
  437. end;
  438. Function GetAStrProp(Instance : TObject;PropInfo : PPropInfo):Pointer;
  439. {
  440. Dirty trick based on fact that AnsiString is just a pointer,
  441. hence can be treated like an integer type.
  442. }
  443. var
  444. value : Pointer;
  445. Index,Ivalue : Longint;
  446. begin
  447. SetIndexValues(PropInfo,Index,IValue);
  448. case (PropInfo^.PropProcs) and 3 of
  449. ptfield:
  450. Value:=Pointer(PLongint(Pointer(Instance)+Longint(PropInfo^.GetProc))^);
  451. ptstatic:
  452. Value:=Pointer(CallIntegerFunc(Instance,PropInfo^.GetProc,Index,IValue));
  453. ptvirtual:
  454. Value:=Pointer(CallIntegerFunc(Instance,
  455. (PPointer(Instance.ClassType)+Longint(PropInfo^.GetProc)),
  456. Index,IValue));
  457. end;
  458. GetAstrProp:=Value;
  459. end;
  460. Function GetSStrProp(Instance : TObject;PropInfo : PPropInfo):ShortString;
  461. var
  462. value : ShortString;
  463. Index,IValue : Longint;
  464. begin
  465. SetIndexValues(PropInfo,Index,IValue);
  466. case (PropInfo^.PropProcs) and 3 of
  467. ptfield:
  468. Value:=PShortString(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  469. ptstatic:
  470. CallSStringFunc(Instance,PropInfo^.GetProc,Index,IValue,Value);
  471. ptvirtual:
  472. CallSSTringFunc(Instance,
  473. (PPointer(Instance.ClassType)+Longint(PropInfo^.GetProc)),
  474. Index,Ivalue,Value);
  475. end;
  476. GetSStrProp:=Value;
  477. end;
  478. function GetStrProp(Instance : TObject;PropInfo : PPropInfo) : Ansistring;
  479. begin
  480. Case Propinfo^.PropType^.Kind of
  481. tkSString : Result:=GetSStrProp(Instance,PropInfo);
  482. tkAString : Pointer(Result):=GetAStrProp(Instance,Propinfo);
  483. else
  484. Result:='';
  485. end;
  486. end;
  487. procedure SetAStrProp(Instance : TObject;PropInfo : PPropInfo;
  488. const Value : AnsiString);
  489. {
  490. Dirty trick based on fact that AnsiString is just a pointer,
  491. hence can be treated like an integer type.
  492. }
  493. var
  494. Index,Ivalue : Longint;
  495. begin
  496. SetIndexValues(PropInfo,Index,IValue);
  497. case (PropInfo^.PropProcs) and 3 of
  498. ptfield:
  499. PLongint(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Longint(Pointer(Value)) ;
  500. ptstatic:
  501. CallIntegerProc(Instance,PropInfo^.SetProc,Longint(Pointer(Value)),Index,IValue);
  502. ptvirtual:
  503. CallIntegerProc(Instance,
  504. (PPointer(Instance.ClassType)+Longint(PropInfo^.SetProc)),
  505. Longint(Pointer(Value)),Index,IValue);
  506. end;
  507. end;
  508. procedure SetSStrProp(Instance : TObject;PropInfo : PPropInfo;
  509. const Value : ShortString);
  510. Var Index,IValue: longint;
  511. begin
  512. SetIndexValues(PRopInfo,Index,IValue);
  513. case (PropInfo^.PropProcs) and 3 of
  514. ptfield:
  515. PShortString(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
  516. ptstatic:
  517. CallSStringProc(Instance,PropInfo^.GetProc,Value,Index,IValue);
  518. ptvirtual:
  519. CallSStringProc(Instance,
  520. (PPointer(Instance.ClassType)+Longint(PropInfo^.GetProc)),
  521. Value,Index,IValue);
  522. end;
  523. end;
  524. procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo;
  525. const Value : AnsiString);
  526. begin
  527. Case Propinfo^.PropType^.Kind of
  528. tkSString : SetSStrProp(Instance,PropInfo,Value);
  529. tkAString : SetAStrProp(Instance,Propinfo,Value);
  530. end;
  531. end;
  532. function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;
  533. var
  534. Index,Ivalue : longint;
  535. Value : Extended;
  536. begin
  537. SetIndexValues(PropInfo,Index,Ivalue);
  538. case (PropInfo^.PropProcs) and 3 of
  539. ptfield:
  540. Case GetTypeData(PropInfo^.PropType)^.FloatType of
  541. ftSingle:
  542. Value:=PSingle(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  543. ftDouble:
  544. Value:=PDouble(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  545. ftExtended:
  546. Value:=PExtended(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  547. ftcomp:
  548. Value:=PComp(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  549. { Uncommenting this code results in a internal error!!
  550. ftFixed16:
  551. Value:=PFixed16(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  552. ftfixed32:
  553. Value:=PFixed32(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  554. }
  555. end;
  556. ptstatic:
  557. Value:=CallExtendedFunc(Instance,PropInfo^.GetProc,Index,IValue);
  558. ptvirtual:
  559. Value:=CallExtendedFunc(Instance,
  560. (PPointer(Instance.ClassType)+Longint(PropInfo^.GetProc)),
  561. Index,IValue);
  562. end;
  563. Result:=Value;
  564. end;
  565. procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo;
  566. Value : Extended);
  567. Var IValue,Index : longint;
  568. begin
  569. SetIndexValues(PropInfo,Index,Ivalue);
  570. case (PropInfo^.PropProcs) and 3 of
  571. ptfield:
  572. Case GetTypeData(PropInfo^.PropType)^.FloatType of
  573. ftSingle:
  574. PSingle(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
  575. ftDouble:
  576. PDouble(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
  577. ftExtended:
  578. PExtended(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
  579. ftcomp:
  580. PComp(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Comp(Value);
  581. { Uncommenting this code results in a internal error!!
  582. ftFixed16:
  583. PFixed16(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
  584. ftfixed32:
  585. PFixed32(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
  586. }
  587. end;
  588. ptstatic:
  589. CallExtendedProc(Instance,PropInfo^.SetProc,Value,Index,IValue);
  590. ptvirtual:
  591. CallExtendedProc(Instance,
  592. (PPointer(Instance.ClassType)+Longint(PropInfo^.GetProc)),
  593. Value,Index,IValue);
  594. end;
  595. end;
  596. function GetVariantProp(Instance : TObject;PropInfo : PPropInfo): Variant;
  597. begin
  598. {!!!!!!!!!!!}
  599. Result:=nil;
  600. end;
  601. procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo;
  602. const Value: Variant);
  603. begin
  604. {!!!!!!!!!!!}
  605. end;
  606. function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod;
  607. begin
  608. {!!!!!!!!!!!!}
  609. Result:=nil;
  610. end;
  611. procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo;
  612. const Value : TMethod);
  613. begin
  614. {!!!!!!!!!!!}
  615. end;
  616. function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
  617. Var PS : PShortString;
  618. PT : PTypeData;
  619. begin
  620. PT:=GetTypeData(TypeInfo);
  621. // ^.BaseType);
  622. // If PT^.MinValue<0 then Value:=Ord(Value<>0); {map to 0/1}
  623. PS:=@PT^.NameList;
  624. While Value>0 Do
  625. begin
  626. PS:=PS+PByte(PS)^+1;
  627. Dec(Value);
  628. end;
  629. Result:=PS^;
  630. end;
  631. function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
  632. Var PS : PShortString;
  633. PT : PTypeData;
  634. Count : longint;
  635. begin
  636. If Length(Name)=0 then exit(-1);
  637. PT:=GetTypeData(TypeInfo);
  638. Count:=0;
  639. Result:=-1;
  640. PS:=@PT^.NameList;
  641. While (Result=-1) and (PByte(PS)^<>0) do
  642. begin
  643. If PS^=Name then
  644. Result:=Count;
  645. PS:=PS+PByte(PS)^;
  646. Inc(Count);
  647. end;
  648. end;
  649. end.
  650. {
  651. $Log$
  652. Revision 1.23 1999-06-04 12:48:37 michael
  653. * Fix by Sebastian Guenther.
  654. Revision 1.22 1999/05/19 12:03:23 florian
  655. * the set/get procedures must be called with call %edi instead call (%edi)
  656. * handling of extended and string properties fixed
  657. Revision 1.21 1999/05/07 11:02:14 florian
  658. * two typos fixed
  659. Revision 1.20 1999/05/03 07:30:07 michael
  660. * Fixes in getenum*
  661. Revision 1.19 1999/04/08 11:31:04 peter
  662. * removed warnings
  663. Revision 1.18 1999/01/19 16:08:12 pierre
  664. ?? is callSStringProc a function ??
  665. Revision 1.17 1998/12/15 22:43:13 peter
  666. * removed temp symbols
  667. Revision 1.16 1998/12/02 12:35:07 michael
  668. More changes for type-information
  669. Revision 1.15 1998/11/26 14:57:47 michael
  670. + Added packrecords 1
  671. Revision 1.11 1998/09/24 23:45:28 peter
  672. * updated for auto objpas loading
  673. Revision 1.10 1998/09/20 08:25:34 florian
  674. + description of tpropinfo.propprocs bit 6 added
  675. Revision 1.9 1998/09/19 15:25:45 florian
  676. * procedure GetOrdProp added
  677. Revision 1.8 1998/09/19 08:33:53 florian
  678. + some procedures added
  679. Revision 1.7 1998/09/08 09:52:31 florian
  680. * small problems fixed
  681. Revision 1.6 1998/09/08 00:08:36 michael
  682. Made it compilable
  683. Revision 1.5 1998/09/07 23:11:43 florian
  684. + more fields to TTypeInfo added
  685. Revision 1.4 1998/09/07 19:34:47 florian
  686. * constant value is now supported as stored condition
  687. Revision 1.3 1998/09/07 08:32:59 florian
  688. + procedure IsStoredProc added
  689. Revision 1.2 1998/09/06 21:27:05 florian
  690. + some methods and declarations added
  691. Revision 1.1 1998/08/25 22:30:00 florian
  692. + initial revision:
  693. o constants
  694. o basic type data record
  695. }