← Back to branch summary

~ubuntu-branches/ubuntu/feisty/fpc/feisty

« back to all changes in this revision

Viewing changes to fpcdocs/typinfex/trtti1.pp

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2007-01-27 20:08:50 UTC
  • mfrom: (1.2.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070127200850-9mrptaqqjsx9nwa7
Tags: 2.0.4-5
* Fixed Build-Depends.
* Add myself to Uploaders in debian/control.
* Make sure that the sources are really patched before building them.
* Build unit 'libc' on powerpc too.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcdocs/typinfex/trtti1.pp
 
1
Program trtti1;
 
2
 
 
3
{$Mode Delphi}
 
4
{$M+}
 
5
 
 
6
Uses
 
7
  Rttiobj,Typinfo;
 
8
 
 
9
Procedure DumpMem ( PL : PByte );
 
10
 
 
11
Var I,j : longint;
 
12
 
 
13
begin
 
14
  For I:=1 to 16 do
 
15
    begin
 
16
    Write ((I-1)*16:3,' :');
 
17
    For J:=1 to 10  do
 
18
      begin
 
19
      If (PL^>31) and (PL^<129) then
 
20
         Write('  ',CHar(PL^))
 
21
      else
 
22
        Write (PL^:3);
 
23
      Write (' ');
 
24
      inc(pl);
 
25
      end;
 
26
    writeln;
 
27
    end;
 
28
end;
 
29
 
 
30
 
 
31
Function ProcType (PP : Byte) : String;
 
32
 
 
33
begin
 
34
  Case PP and 3 of
 
35
    ptfield   : Result:='from Field';
 
36
    ptstatic  : Result:='with static method';
 
37
    ptVirtual : Result:='with virtual method';
 
38
    ptconst   : Result:='with Const';
 
39
   end;
 
40
end;
 
41
 
 
42
Procedure DumpTypeInfo (O : TMyTestObject);
 
43
 
 
44
Var
 
45
    PT : PTypeData;
 
46
    PI : PTypeInfo;
 
47
    I  : Longint;
 
48
    PP : PPropList;
 
49
 
 
50
begin
 
51
  PI:=O.ClassInfo;
 
52
  Writeln ('Type kind : ',TypeNames[PI^.Kind]);
 
53
  Writeln ('Type name : ',PI^.Name);
 
54
  PT:=GetTypeData(PI);
 
55
  //DumpMem(PByte(PI));
 
56
  If PT^.ParentInfo=Nil then
 
57
    Writeln ('Object has no parent info')
 
58
  else
 
59
    Writeln ('Object has parent info');
 
60
  Writeln ('Property Count : ',PT^.PropCount);
 
61
  Writeln ('Unit name      : ',PT^.UnitName);
 
62
  GetMem (PP,PT^.PropCount*SizeOf(Pointer));
 
63
  GetPropInfos(PI,PP);
 
64
  For I:=0 to PT^.PropCount-1 do
 
65
  If PP^[i]<>Nil then
 
66
    With PP^[I]^ do
 
67
      begin
 
68
      Writeln ('Property name : ',Name);
 
69
      Writeln (' Type kind: ',TypeNames[PropType^.Kind]);
 
70
      Writeln (' Type Name: ',PropType^.Name);
 
71
      If GetProc=Nil then Write ('No');
 
72
      Writeln (' Getproc available');
 
73
      If SetProc=Nil then Write ('No');
 
74
      Writeln (' Setproc available');
 
75
      If StoredProc=Nil then Write ('No');
 
76
      Writeln (' Storedproc available');
 
77
      Writeln (' Get property ',proctype(Propprocs));
 
78
      Writeln (' Set Property ',proctype(propprocs shr 2));
 
79
      Writeln (' Stored Property ',proctype(propprocs shr 4));
 
80
      Writeln (' Default : ',Default,' Index : ',Index);
 
81
      Writeln (' NameIndex : ',NameIndex);
 
82
      end;
 
83
end;
 
84
 
 
85
Procedure PrintObject ( Obj: TMyTestObject);
 
86
 
 
87
begin
 
88
  With Obj do
 
89
    begin
 
90
    Writeln ('Field properties :');
 
91
    Writeln ('Property booleanField    : ',booleanField);
 
92
    Writeln ('Property ByteField       : ',ByteField);
 
93
    Writeln ('Property CharField       : ',CharField);
 
94
    Writeln ('Property WordField       : ',WordField);
 
95
    Writeln ('Property IntegerField    : ',IntegerField);
 
96
    Writeln ('Property LongintField    : ',LongintField);
 
97
    Writeln ('Property CardinalField   : ',CardinalField);
 
98
    Writeln ('Property RealField       : ',RealField);
 
99
    Writeln ('Property ExtendedField   : ',ExtendedFIeld);
 
100
    Writeln ('Property AnsiStringField : ',AnsiStringField);
 
101
    Writeln ('Property MyEnumField     : ',ord(MyEnumField));
 
102
    Writeln ('Method properties :');
 
103
    Writeln ('Property booleanMethod    : ',BooleanMethod);
 
104
    Writeln ('Property ByteMethod       : ',ByteMethod);
 
105
    Writeln ('Property CharMethod       : ',CharMethod);
 
106
    Writeln ('Property WordMethod       : ',WordMethod);
 
107
    Writeln ('Property IntegerMethod    : ',IntegerMethod);
 
108
    Writeln ('Property LongintMethod    : ',LongintMethod);
 
109
    Writeln ('Property CardinalMethod   : ',CardinalMethod);
 
110
    Writeln ('Property RealMethod       : ',RealMethod);
 
111
    Writeln ('Property ExtendedMethod   : ',ExtendedMethod);
 
112
    Writeln ('Property AnsiStringMethod : ',AnsiStringMethod);
 
113
    Writeln ('Property MyEnumMethod     : ',ord(MyEnumMethod));
 
114
    Writeln ('VirtualMethod properties :');
 
115
    Writeln ('Property booleanVirtualMethod    : ',BooleanVirtualMethod);
 
116
    Writeln ('Property ByteVirtualMethod       : ',ByteVirtualMethod);
 
117
    Writeln ('Property CharVirtualMethod       : ',CharVirtualMethod);
 
118
    Writeln ('Property WordVirtualMethod       : ',WordVirtualMethod);
 
119
    Writeln ('Property IntegerVirtualMethod    : ',IntegerVirtualMethod);
 
120
    Writeln ('Property LongintVirtualMethod    : ',LongintVirtualMethod);
 
121
    Writeln ('Property CardinalVirtualMethod   : ',CardinalVirtualMethod);
 
122
    Writeln ('Property RealVirtualMethod       : ',RealVirtualMethod);
 
123
    Writeln ('Property ExtendedVirtualMethod   : ',ExtendedVirtualMethod);
 
124
    Writeln ('Property AnsiStringVirtualMethod : ',AnsiStringVirtualMethod);
 
125
    Writeln ('Property MyEnumVirtualMethod     : ',ord(MyEnumVirtualMethod));
 
126
    end;
 
127
end;
 
128
 
 
129
Procedure TestGet (O : TMyTestObject);
 
130
 
 
131
Var
 
132
    PT : PTypeData;
 
133
    PI : PTypeInfo;
 
134
    I,J : Longint;
 
135
    PP : PPropList;
 
136
    prI : PPropInfo;
 
137
 
 
138
begin
 
139
  PI:=O.ClassInfo;
 
140
  Writeln ('Type kind : ',TypeNames[PI^.Kind]);
 
141
  Writeln ('Type name : ',PI^.Name);
 
142
  PT:=GetTypeData(PI);
 
143
  If PT^.ParentInfo=Nil then
 
144
    Writeln ('Object has no parent info')
 
145
  else
 
146
    Writeln ('Object has parent info');
 
147
  Writeln ('Property Count : ',PT^.PropCount);
 
148
  Writeln ('Unit name      : ',PT^.UnitName);
 
149
  GetMem (PP,PT^.PropCount*SizeOf(Pointer));
 
150
  GetPropInfos(PI,PP);
 
151
  For I:=0 to PT^.PropCount-1 do
 
152
    begin
 
153
    pri:=PP^[i];
 
154
    With Pri^ do
 
155
      begin
 
156
      Write ('(Examining ',name,' : Type : ',TypeNames[PropType^.Kind],', ');
 
157
      If (Proptype^.kind in Ordinaltypes) Then
 
158
        begin
 
159
        J:=GetOrdProp(O,pri);
 
160
        Write ('Value : ',j);
 
161
        If PropType^.Kind=tkenumeration then
 
162
          Write ('(=',GetEnumName(Proptype,J),')')
 
163
        end
 
164
      else
 
165
        Case pri^.proptype^.kind of
 
166
          tkfloat :  begin
 
167
                     Write ('Value : ');
 
168
                     Flush(output);
 
169
                     Write(GetFloatProp(O,pri))
 
170
                     end;
 
171
        tkAstring : begin
 
172
                    Write ('value : ');
 
173
                    flush (output);
 
174
                    Write(GetStrProp(O,Pri));
 
175
                    end;
 
176
        else
 
177
          Write ('Untested type:',ord(pri^.proptype^.kind));
 
178
        end;
 
179
          Writeln (')');
 
180
      end;
 
181
    end;
 
182
end;
 
183
 
 
184
Var O : TMyTestObject;
 
185
 
 
186
begin
 
187
  O:=TMyTestObject.Create;
 
188
  DumpTypeInfo(O);
 
189
  PrintObject(O);
 
190
  testget(o);
 
191
end.