1 it CompilerhelperForInitializingFinalizingVariable;
  2 
  3 interface
  4 
  5 { Compiler helper for initializing/finalizing variable }
  6 
  7 procedure _Initialize(p : Pointer; typeInfo : Pointer);
  8 procedure _InitializeArray(p : Pointer; typeInfo : Pointer; elemCount : NativeUInt);
  9 procedure _InitializeRecord(p : Pointer; typeInfo : Pointer);
 10 
 11   {$IF not defined(X86ASMRTL)}
 12   // dcc64 generated code expects P to remain in RAX on exit from this function.
 13 function _Finalize(P : Pointer; TypeInfo : Pointer): Pointer;
 14 function _FinalizeArray(P : Pointer; TypeInfo : Pointer; ElemCount : NativeUInt): Pointer;
 15 function _FinalizeRecord(P : Pointer; TypeInfo : Pointer): Pointer;
 16   {$ELSE}
 17 procedure _Finalize(p : Pointer; typeInfo : Pointer);
 18 procedure _FinalizeArray(P : Pointer; TypeInfo : Pointer; ElemCount : NativeUInt);
 19 procedure _FinalizeRecord(P : Pointer; TypeInfo : Pointer);
 20   {$ENDIF}
 21 
 22 procedure _CopyRecord(Dest, Source, TypeInfo : Pointer);
 23 procedure _CopyObject(Dest, Source : Pointer; vmtPtrOffs : NativeInt; TypeInfo : Pointer);
 24 procedure _CopyArray(Dest, Source, TypeInfo : Pointer; Count : NativeUInt);
 25 
 26 procedure _AddRef(P : Pointer; TypeInfo : Pointer);
 27 procedure _AddRefArray(P : Pointer; TypeInfo : Pointer; ElemCount : NativeUInt);
 28 procedure _AddRefRecord(P : Pointer; TypeInfo : Pointer);
 29 
 30 function _New(Size : NativeInt; TypeInfo : Pointer): Pointer;
 31 procedure _Dispose(P : Pointer; TypeInfo : Pointer);
 32 
 33 procedure InitializeArray(p : Pointer; typeInfo : Pointer; elemCount : NativeUInt);
 34 procedure CopyArray(Dest, Source, TypeInfo : Pointer; Count : NativeInt);
 35 procedure FinalizeArray(P : Pointer; TypeInfo : Pointer; Count : NativeUInt);
 36 
 37 
 38 implementation
 39 
 40 { ===========================================================================
 41   InitializeRecord, InitializeArray, and Initialize are PIC safe even though
 42   they alter EBX because they only call each other.  They never call out to
 43   other functions and they don t access global data.
 44 
 45   FinalizeRecord, Finalize, and FinalizeArray are PIC safe because they call
 46   Pascal routines which will have EBX fixup prologs.
 47   ===========================================================================}
 48 procedure _VarClr(var v : TVarData);
 49 begin
 50   if Assigned(VarClearProc) then
 51     VarClearProc(v)
 52   else
 53     Error(reVarInvalidOp);
 54 end;
 55 
 56 procedure _VarCopy(var Dest : TVarData; const Src : TVarData);
 57 begin
 58   if Assigned(VarCopyProc) then
 59     VarCopyProc(Dest, Src)
 60   else
 61     Error(reVarInvalidOp);
 62 end;
 63 
 64 procedure _VarAddRef(var v : TVarData);
 65 begin
 66   if Assigned(VarAddRefProc) then
 67     VarAddRefProc(v)
 68   else
 69     Error(reVarInvalidOp);
 70 end;
 71 
 72 { ===========================================================================
 73   InitializeRecord, InitializeArray, and Initialize are PIC safe even though
 74   they alter EBX because they only call each other.  They never call out to
 75   other functions and they don t access global data.
 76 
 77   FinalizeRecord, Finalize, and FinalizeArray are PIC safe because they call
 78   Pascal routines which will have EBX fixup prologs.
 79   ===========================================================================}
 80       
 81 procedure _InitializeRecord(p : Pointer; typeInfo : Pointer);
 82 var
 83   FT : PFieldTable;
 84   I : Cardinal;
 85 begin
 86   FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0]));
 87   if FT.Count > 0 then
 88   begin
 89     for I := FT.Count - 1 downto 0 do
 90       {$IFDEF WEAKREF}
 91       if FT.Fields[I].TypeInfo <> nil then
 92         {$ENDIF}
 93         _InitializeArray(Pointer(PByte(P) + UIntPtr(FT.Fields[I].Offset)),
 94           FT.Fields[I].TypeInfo^, 1);
 95   end;
 96 end;
 97 
 98 function _FinalizeRecord(P : Pointer; TypeInfo : Pointer): Pointer;
 99 var
100   FT : PFieldTable;
101   I : Cardinal;
102   {$IFDEF WEAKREF}
103   Weak : Boolean;
104   {$ENDIF}
105 begin
106   FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));
107   if FT.Count > 0 then
108   begin
109     {$IFDEF WEAKREF}
110     Weak := false;
111     {$ENDIF}
112     for I := 0 to FT.Count - 1 do
113     begin
114       {$IFDEF WEAKREF}
115       if FT.Fields[I].TypeInfo = nil then
116       begin
117         Weak := true;
118         Continue;
119       end;
120       if not Weak then
121       begin
122         {$ENDIF}
123         _FinalizeArray(Pointer(PByte(P) + IntPtr(FT.Fields[I].Offset)),
124           FT.Fields[I].TypeInfo^, 1);
125         {$IFDEF WEAKREF}
126       end 
127       else
128       begin
129         case FT.Fields[I].TypeInfo^.Kind of
130           {$IFDEF WEAKINTFREF}
131           tkInterface: 
132             _IntfWeakClear(IInterface(Pointer(PByte(P) +
133               IntPtr(FT.Fields[I].Offset))^));
134           {$ENDIF}
135           {$IFDEF WEAKINSTREF}
136           tkClass: 
137             _InstWeakClear(TObject(Pointer(PByte(P) + IntPtr(FT.Fields[I].Offset))^));
138           {$ENDIF}
139           {$IFDEF WEAKREF}
140           tkMethod: 
141             _ClosureRemoveWeakRef(TMethod(Pointer(PByte(P) +
142               IntPtr(FT.Fields[I].Offset))^));
143           {$ENDIF}
144           else
145             Error(reInvalidPtr);
146         end;
147       end;
148       {$ENDIF}
149     end;
150   end;
151   Result := P;
152 end;
153 
154 procedure _InitializeArray(p : Pointer; typeInfo : Pointer; elemCount : NativeUInt);
155 var
156   FT : PFieldTable;
157   I : Cardinal;
158 begin
159   if elemCount = 0 then 
160     Exit;
161   case PTypeInfo(typeInfo).Kind of
162     {$IFDEF WEAKREF}
163     tkMethod:
164       while elemCount > 0 do
165       begin
166         TMethod(P^).Data := nil;
167         TMethod(P^).Code := nil;
168         Inc(PByte(P), SizeOf(TMethod));
169         Dec(elemCount);
170       end;
171     {$ENDIF}
172     {$IFDEF AUTOREFCOUNT}
173     tkClass,
174     {$ENDIF}
175     tkLString, tkWString, tkInterface, tkDynArray, tkUString:
176       while elemCount > 0 do
177       begin
178         PPointer(P)^ := nil;
179         Inc(PByte(P), SizeOf(Pointer));
180         Dec(elemCount);
181       end;
182     tkVariant:
183       while elemCount > 0 do
184       begin
185         with PVarData(P)^ do
186           for I := Low(RawData) to High(RawData) do 
187             RawData[I] := 0;
188         Inc(PByte(P), SizeOf(TVarData));
189         Dec(elemCount);
190       end;
191     tkArray:
192       begin
193         FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0]));
194         while elemCount > 0 do
195         begin
196           _InitializeArray(P, FT.Fields[0].TypeInfo^, FT.Count);
197           Inc(PByte(P), FT.Size);
198           Dec(elemCount);
199         end;
200       end;
201     tkRecord:
202       begin
203         FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0]));
204         while elemCount > 0 do
205         begin
206           _InitializeRecord(P, typeInfo);
207           Inc(PByte(P), FT.Size);
208           Dec(elemCount);
209         end;
210       end;
211     else
212       Error(reInvalidPtr);
213   end;
214 end;
215 
216 function _FinalizeArray(P : Pointer; TypeInfo : Pointer; ElemCount : NativeUInt): Pointer;
217 var
218   FT : PFieldTable;
219 begin
220   Result := P;
221   if ElemCount = 0 then 
222     Exit;
223   case PTypeInfo(TypeInfo).Kind of
224     {$IFDEF WEAKREF}
225     tkMethod:
226       while ElemCount > 0 do
227       begin
228         _ClosureRemoveWeakRef(TMethod(P^));
229         Inc(PByte(P), SizeOf(TMethod));
230         Dec(ElemCount);
231       end;
232     {$ENDIF}
233     {$IFDEF AUTOREFCOUNT}
234     tkClass:
235       while ElemCount > 0 do
236       begin
237         _InstClear(TObject(P^));
238         Inc(PByte(P), SizeOf(Pointer));
239         Dec(ElemCount);
240       end;
241     {$ENDIF}
242     tkLString: 
243       _LStrArrayClr(P^, ElemCount);
244     tkWString: 
245       _WStrArrayClr(P^, ElemCount);
246     tkUString: 
247       _UStrArrayClr(P^, ElemCount);
248     tkVariant:
249       while ElemCount > 0 do
250       begin
251         _VarClr(PVarData(P)^);
252         Inc(PByte(P), SizeOf(TVarData));
253         Dec(ElemCount);
254       end;
255     tkArray:
256       begin
257         FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0]));
258         while ElemCount > 0 do
259         begin
260           _FinalizeArray(P, FT.Fields[0].TypeInfo^, FT.Count);
261           Inc(PByte(P), FT.Size);
262           Dec(ElemCount);
263         end;
264       end;
265     tkRecord:
266       begin
267         FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));
268         while ElemCount > 0 do
269         begin
270           _FinalizeRecord(P, TypeInfo);
271           Inc(PByte(P), FT.Size);
272           Dec(ElemCount);
273         end;
274       end;
275     tkInterface:
276       while ElemCount > 0 do
277       begin
278         _IntfClear(IInterface(P^));
279         Inc(PByte(P), SizeOf(Pointer));
280         Dec(ElemCount);
281       end;
282     tkDynArray:
283       while ElemCount > 0 do
284       begin
285         { The cast and dereference of P here is to fake out the call to
286           _DynArrayClear.  That function expects a var parameter.  Our
287           declaration says we got a non-var parameter, but because of
288           the data type that got passed to us (tkDynArray), this isn t
289           strictly true.  The compiler will have passed us a reference. }
290         _DynArrayClear(PPointer(P)^, typeInfo);
291         Inc(PByte(P), SizeOf(Pointer));
292         Dec(ElemCount);
293       end;
294     else
295       Error(reInvalidPtr);
296   end;
297 end;
298 
299 procedure _AddRefRecord(P : Pointer; TypeInfo : Pointer);
300 var
301   FT : PFieldTable;
302   I : Cardinal;
303 begin
304   FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));
305   if FT.Count > 0 then
306   begin
307     for I := 0 to FT.Count - 1 do
308     begin
309       {$IFDEF WEAKREF}
310       // Check for the sentinal indicating the following fields are weak references
311       // which don t need to be reference counted
312       if FT.Fields[I].TypeInfo = nil then
313         Break;
314       {$ENDIF}
315       _AddRefArray(Pointer(PByte(P) + UIntPtr(FT.Fields[I].Offset)),
316         FT.Fields[I].TypeInfo^, 1);
317     end;
318   end;
319 end;
320 
321 procedure _AddRefArray(P : Pointer; TypeInfo : Pointer; ElemCount : NativeUInt);
322 var
323   FT : PFieldTable;
324 begin
325   if ElemCount = 0 then 
326     Exit;
327   case PTypeInfo(TypeInfo).Kind of
328     {$IFDEF WEAKREF}
329     tkMethod:
330       while ElemCount > 0 do
331       begin
332         _ClosureAddWeakRef(TMethod(P^));
333         Inc(PByte(P), SizeOf(TMethod));
334         Dec(ElemCount);
335       end;
336     {$ENDIF}
337     {$IFDEF AUTOREFCOUNT}
338     tkClass:
339       while ElemCount > 0 do
340       begin
341         _InstAddRef(TObject(P^));
342         Inc(PByte(P), SizeOf(Pointer));
343         Dec(ElemCount);
344       end;
345     {$ENDIF}
346     tkLString:
347       while ElemCount > 0 do
348       begin
349         _LStrAddRef(PPointer(P)^);
350         Inc(PByte(P), SizeOf(Pointer));
351         Dec(ElemCount);
352       end;
353     tkWString:
354       while ElemCount > 0 do
355       begin
356         {$IFDEF MSWINDOWS}
357         _WStrAddRef(PWideString(P)^);
358         {$ELSE}
359         _WStrAddRef(PPointer(P)^);
360         {$ENDIF}
361         Inc(PByte(P), SizeOf(Pointer));
362         Dec(ElemCount);
363       end;
364     tkUString:
365       while ElemCount > 0 do
366       begin
367         _UStrAddRef(PPointer(P)^);
368         Inc(PByte(P), SizeOf(Pointer));
369         Dec(ElemCount);
370       end;
371     tkVariant:
372       while ElemCount > 0 do
373       begin
374         _VarAddRef(PVarData(P)^);
375         Inc(PByte(P), SizeOf(TVarData));
376         Dec(ElemCount);
377       end;
378     tkArray:
379       begin
380         FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));
381         while ElemCount > 0 do
382         begin
383           _AddRefArray(P, FT.Fields[0].TypeInfo^, FT.Count);
384           Inc(PByte(P), FT.Size);
385           Dec(ElemCount);
386         end;
387       end;
388     tkRecord:
389       begin
390         FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));
391         while ElemCount > 0 do
392         begin
393           _AddRefRecord(P, TypeInfo);
394           Inc(PByte(P), FT.Size);
395           Dec(ElemCount);
396         end;
397       end;
398     tkInterface:
399       while ElemCount > 0 do
400       begin
401         _IntfAddRef(IInterface(P^));
402         Inc(PByte(P), SizeOf(Pointer));
403         Dec(ElemCount);
404       end;
405     tkDynArray:
406       while ElemCount > 0 do
407       begin
408         _DynArrayAddRef(PPointer(P)^);
409         Inc(PByte(P), SizeOf(Pointer));
410         Dec(ElemCount);
411       end;
412     else
413       Error(reInvalidPtr);
414   end;
415 end;
416 
417 procedure _AddRef(P : Pointer; TypeInfo : Pointer);
418 begin
419   _AddRefArray(P, TypeInfo, 1);
420 end;
421 
422 procedure _CopyRecord(Dest, Source, TypeInfo : Pointer);