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 var100   FT : PFieldTable;101   I : Cardinal;102   {$IFDEF WEAKREF}103   Weak : Boolean;104   {$ENDIF}105 begin106   FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));107   if FT.Count > 0 then108   begin109     {$IFDEF WEAKREF}110     Weak := false;111     {$ENDIF}112     for I := 0 to FT.Count - 1 do113     begin114       {$IFDEF WEAKREF}115       if FT.Fields[I].TypeInfo = nil then116       begin117         Weak := true;118         Continue;119       end;120       if not Weak then121       begin122         {$ENDIF}123         _FinalizeArray(Pointer(PByte(P) + IntPtr(FT.Fields[I].Offset)),124           FT.Fields[I].TypeInfo^, 1);125         {$IFDEF WEAKREF}126       end 127       else128       begin129         case FT.Fields[I].TypeInfo^.Kind of130           {$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           else145             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 var156   FT : PFieldTable;157   I : Cardinal;158 begin159   if elemCount = 0 then 160     Exit;161   case PTypeInfo(typeInfo).Kind of162     {$IFDEF WEAKREF}163     tkMethod:164       while elemCount > 0 do165       begin166         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 do177       begin178         PPointer(P)^ := nil;179         Inc(PByte(P), SizeOf(Pointer));180         Dec(elemCount);181       end;182     tkVariant:183       while elemCount > 0 do184       begin185         with PVarData(P)^ do186           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       begin193         FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0]));194         while elemCount > 0 do195         begin196           _InitializeArray(P, FT.Fields[0].TypeInfo^, FT.Count);197           Inc(PByte(P), FT.Size);198           Dec(elemCount);199         end;200       end;201     tkRecord:202       begin203         FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0]));204         while elemCount > 0 do205         begin206           _InitializeRecord(P, typeInfo);207           Inc(PByte(P), FT.Size);208           Dec(elemCount);209         end;210       end;211     else212       Error(reInvalidPtr);213   end;214 end;215 216 function _FinalizeArray(P : Pointer; TypeInfo : Pointer; ElemCount : NativeUInt): Pointer;217 var218   FT : PFieldTable;219 begin220   Result := P;221   if ElemCount = 0 then 222     Exit;223   case PTypeInfo(TypeInfo).Kind of224     {$IFDEF WEAKREF}225     tkMethod:226       while ElemCount > 0 do227       begin228         _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 do236       begin237         _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 do250       begin251         _VarClr(PVarData(P)^);252         Inc(PByte(P), SizeOf(TVarData));253         Dec(ElemCount);254       end;255     tkArray:256       begin257         FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0]));258         while ElemCount > 0 do259         begin260           _FinalizeArray(P, FT.Fields[0].TypeInfo^, FT.Count);261           Inc(PByte(P), FT.Size);262           Dec(ElemCount);263         end;264       end;265     tkRecord:266       begin267         FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));268         while ElemCount > 0 do269         begin270           _FinalizeRecord(P, TypeInfo);271           Inc(PByte(P), FT.Size);272           Dec(ElemCount);273         end;274       end;275     tkInterface:276       while ElemCount > 0 do277       begin278         _IntfClear(IInterface(P^));279         Inc(PByte(P), SizeOf(Pointer));280         Dec(ElemCount);281       end;282     tkDynArray:283       while ElemCount > 0 do284       begin285         { The cast and dereference of P here is to fake out the call to286           _DynArrayClear.  That function expects a var parameter.  Our287           declaration says we got a non-var parameter, but because of288           the data type that got passed to us (tkDynArray), this isn t289           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     else295       Error(reInvalidPtr);296   end;297 end;298 299 procedure _AddRefRecord(P : Pointer; TypeInfo : Pointer);300 var301   FT : PFieldTable;302   I : Cardinal;303 begin304   FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));305   if FT.Count > 0 then306   begin307     for I := 0 to FT.Count - 1 do308     begin309       {$IFDEF WEAKREF}310       // Check for the sentinal indicating the following fields are weak references311       // which don t need to be reference counted312       if FT.Fields[I].TypeInfo = nil then313         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 var323   FT : PFieldTable;324 begin325   if ElemCount = 0 then 326     Exit;327   case PTypeInfo(TypeInfo).Kind of328     {$IFDEF WEAKREF}329     tkMethod:330       while ElemCount > 0 do331       begin332         _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 do340       begin341         _InstAddRef(TObject(P^));342         Inc(PByte(P), SizeOf(Pointer));343         Dec(ElemCount);344       end;345     {$ENDIF}346     tkLString:347       while ElemCount > 0 do348       begin349         _LStrAddRef(PPointer(P)^);350         Inc(PByte(P), SizeOf(Pointer));351         Dec(ElemCount);352       end;353     tkWString:354       while ElemCount > 0 do355       begin356         {$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 do366       begin367         _UStrAddRef(PPointer(P)^);368         Inc(PByte(P), SizeOf(Pointer));369         Dec(ElemCount);370       end;371     tkVariant:372       while ElemCount > 0 do373       begin374         _VarAddRef(PVarData(P)^);375         Inc(PByte(P), SizeOf(TVarData));376         Dec(ElemCount);377       end;378     tkArray:379       begin380         FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));381         while ElemCount > 0 do382         begin383           _AddRefArray(P, FT.Fields[0].TypeInfo^, FT.Count);384           Inc(PByte(P), FT.Size);385           Dec(ElemCount);386         end;387       end;388     tkRecord:389       begin390         FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));391         while ElemCount > 0 do392         begin393           _AddRefRecord(P, TypeInfo);394           Inc(PByte(P), FT.Size);395           Dec(ElemCount);396         end;397       end;398     tkInterface:399       while ElemCount > 0 do400       begin401         _IntfAddRef(IInterface(P^));402         Inc(PByte(P), SizeOf(Pointer));403         Dec(ElemCount);404       end;405     tkDynArray:406       while ElemCount > 0 do407       begin408         _DynArrayAddRef(PPointer(P)^);409         Inc(PByte(P), SizeOf(Pointer));410         Dec(ElemCount);411       end;412     else413       Error(reInvalidPtr);414   end;415 end;416 417 procedure _AddRef(P : Pointer; TypeInfo : Pointer);418 begin419   _AddRefArray(P, TypeInfo, 1);420 end;421 422 procedure _CopyRecord(Dest, Source, TypeInfo : Pointer);423 var424   FT, EFT : PFieldTable;425   I, Count, L : Cardinal;426   {$IFDEF WEAKREF}427   J, K : Cardinal;428   {$ENDIF}429   Offset : UIntPtr;430   FTypeInfo : PTypeInfo;431   DestOff, SrcOff : Pointer;432 begin433   FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));434   Offset := 0;435   if FT.Count > 0 then436   begin437     Count := FT.Count;438     {$IFDEF WEAKREF}439     J := 0;440     K := Count;441     for I := Count - 1 downto 0 do442       if FT.Fields[I].TypeInfo = nil then443       begin444         K := I + 1; // found the weak sentinal445         Dec(Count); // remove the sentinal from consideration446         Break;447       end;448     {$ENDIF}449     for L := 0 to Count - 1 do450     begin451       {$IFDEF WEAKREF}452       if (FT.Fields[J].TypeInfo <> nil) and453         ((K = FT.Count) or (FT.Fields[J].Offset < FT.Fields[K].Offset)) then454       begin455         I := J;456         Inc(J);457       end 458       else459       begin460         I := K;461         Inc(K);462       end;463       {$ELSE}464       I := L;465       {$ENDIF}466       if FT.Fields[I].Offset > Offset then467         Move(Pointer(PByte(Source) + Offset)^,468           Pointer(PByte(Dest) + Offset)^,469           FT.Fields[I].Offset - Offset);470       Offset := FT.Fields[I].Offset;471       FTypeInfo := FT.Fields[I].TypeInfo^;472       DestOff := Pointer(PByte(Dest) + Offset);473       SrcOff := Pointer(PByte(Source) + Offset);474       case FTypeInfo.Kind of475         {$IFDEF WEAKREF}476         tkMethod:477           begin478             _CopyClosure(PMethod(DestOff)^, PMethod(SrcOff)^);479             Inc(Offset, SizeOf(TMethod));480           end;481         {$ENDIF}482         {$IFDEF AUTOREFCOUNT}483         tkClass:484           begin485             {$IFDEF WEAKINSTREF}486             if I > J then487               _InstWeakCopy(TObject(PPointer(DestOff)^),488                 TObject(PPointer(SrcOff)^))489             else490               {$ENDIF}491               _InstCopy(TObject(PPointer(DestOff)^), TObject(PPointer(SrcOff)^));492             Inc(Offset, SizeOf(Pointer));493           end;494         {$ENDIF}495         tkLString:496           begin497             _LStrAsg(_PAnsiStr(DestOff)^, _PAnsiStr(SrcOff)^);498             Inc(Offset, SizeOf(Pointer));499           end;500         tkWString:501           begin502             _WStrAsg(_PWideStr(DestOff)^, _PWideStr(SrcOff)^);503             Inc(Offset, SizeOf(Pointer));504           end;505         tkUString:506           begin507             _UStrAsg(PUnicodeString(DestOff)^, PUnicodeString(SrcOff)^);508             Inc(Offset, SizeOf(Pointer));509           end;510         tkVariant:511           begin512             _VarCopy(PVarData(DestOff)^, PVarData(SrcOff)^);513             Inc(Offset, SizeOf(TVarData));514           end;515         tkArray:516           begin517             EFT :=518               PFieldTable(PByte(FTypeInfo) + Byte(PTypeInfo(FTypeInfo).Name[0]));519             _CopyArray(DestOff, SrcOff, EFT.Fields[0].TypeInfo^, EFT.Count);520             Inc(Offset, EFT.Size);521           end;522         tkRecord:523           begin524             EFT :=525               PFieldTable(PByte(FTypeInfo) + Byte(PTypeInfo(FTypeInfo).Name[0]));526             _CopyRecord(DestOff, SrcOff, FTypeInfo);527 528             Inc(Offset, EFT.Size);529           end;530         tkInterface:531           begin532             {$IFDEF WEAKINTFREF}533             if I > J then534               _IntfWeakCopy(IInterface(PPointer(DestOff)^),535                 IInterface(PPointer(SrcOff)^))536             else537               {$ENDIF}538               _IntfCopy(IInterface(PPointer(DestOff)^),539                 IInterface(PPointer(SrcOff)^));540             Inc(Offset, SizeOf(Pointer));541           end;542         tkDynArray:543           begin544             _DynArrayAsg(PPointer(DestOff)^, PPointer(SrcOff)^, FTypeInfo);545             Inc(Offset, SizeOf(Pointer));546           end;547         else548           Error(reInvalidPtr);549       end;550     end;551   end;552   if FT.Size > Offset then553     Move(Pointer(PByte(Source) + Offset)^,554       Pointer(PByte(Dest) + Offset)^,555       FT.Size - Offset);556 end;557 558 procedure _CopyObject(Dest, Source : Pointer; vmtPtrOffs : NativeInt; TypeInfo : Pointer);559 var560   SavedVmtPtr : Pointer;561 begin562   SavedVmtPtr := PPointer(PByte(Dest) + vmtPtrOffs)^;563   _CopyRecord(Dest, Source, TypeInfo);564   PPointer(PByte(Dest) + vmtPtrOffs)^ := SavedVmtPtr;565 end;566 567 procedure _CopyArray(Dest, Source, TypeInfo : Pointer; Count : NativeUInt);568 var569   FT : PFieldTable;570 begin571   if Count = 0 then 572     Exit;573   case PTypeInfo(TypeInfo).Kind of574     {$IFDEF WEAKREF}575     tkMethod:576       while Count > 0 do577       begin578         _CopyClosure(PMethod(Dest)^, PMethod(Source)^);579         Inc(PByte(Dest), SizeOf(TMethod));580         Inc(PByte(Source), SizeOf(TMethod));581         Dec(Count);582       end;583     {$ENDIF}584     {$IFDEF AUTOREFCOUNT}585     tkClass:586       while Count > 0 do587       begin588         _InstCopy(TObject(PPointer(Dest)^), TObject(PPointer(Source)^));589         Inc(PByte(Dest), SizeOf(Pointer));590         Inc(PByte(Source), SizeOf(Pointer));591         Dec(Count);592       end;593     {$ENDIF}594     tkLString:595       while Count > 0 do596       begin597         _LStrAsg(_PAnsiStr(Dest)^, _PAnsiStr(Source)^);598         Inc(PByte(Dest), SizeOf(Pointer));599         Inc(PByte(Source), SizeOf(Pointer));600         Dec(Count);601       end;602     tkWString:603       while Count > 0 do604       begin605         _WStrAsg(_PWideStr(Dest)^, _PWideStr(Source)^);606         Inc(PByte(Dest), SizeOf(Pointer));607         Inc(PByte(Source), SizeOf(Pointer));608         Dec(Count);609       end;610     tkUString:611       while Count > 0 do612       begin613         _UStrAsg(PUnicodeString(Dest)^, PUnicodeString(Source)^);614         Inc(PByte(Dest), SizeOf(Pointer));615         Inc(PByte(Source), SizeOf(Pointer));616         Dec(Count);617       end;618     tkVariant:619       while Count > 0 do620       begin621         _VarCopy(PVarData(Dest)^, PVarData(Source)^);622         Inc(PByte(Dest), SizeOf(TVarData));623         Inc(PByte(Source), SizeOf(TVarData));624         Dec(Count);625       end;626     tkArray:627       begin628         FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));629         while Count > 0 do630         begin631           _CopyArray(Pointer(Dest), Pointer(Source),632             FT.Fields[0].TypeInfo^, FT.Count);633           Inc(PByte(Dest), FT.Size);634           Inc(PByte(Source), FT.Size);635           Dec(Count);636         end;637       end;638     tkRecord:639       begin640         FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));641         while Count > 0 do642         begin643           _CopyRecord(Dest, Source, TypeInfo);644           Inc(PByte(Dest), FT.Size);645           Inc(PByte(Source), FT.Size);646           Dec(Count);647         end;648       end;649     tkInterface:650       while Count > 0 do651       begin652         _IntfCopy(IInterface(PPointer(Dest)^), IInterface(PPointer(Source)^));653         Inc(PByte(Dest), SizeOf(Pointer));654         Inc(PByte(Source), SizeOf(Pointer));655         Dec(Count);656       end;657     tkDynArray:658       while Count > 0 do659       begin660         _DynArrayAsg(PPointer(Dest)^, PPointer(Source)^, TypeInfo);661         Inc(PByte(Dest), SizeOf(Pointer));662         Inc(PByte(Source), SizeOf(Pointer));663         Dec(Count);664       end;665     else666       Error(reInvalidPtr);667   end;668 end;669 670 procedure CopyArray(Dest, Source, TypeInfo : Pointer; Count : NativeInt);671 begin672   if Count > 0 then673     _CopyArray(Dest, Source, TypeInfo, Count);674 end;675 676 procedure InitializeArray(p : Pointer; typeInfo : Pointer; elemCount : NativeUInt);677 begin678   _InitializeArray(p, typeInfo, elemCount);679 end;680 681 procedure FinalizeArray(P, TypeInfo : Pointer; Count : NativeUInt);682 begin683   _FinalizeArray(P, TypeInfo, Count);684 end;685 686 procedure _Initialize(p : Pointer; typeInfo : Pointer);687 begin688   _InitializeArray(p, typeInfo, 1);689 end;690 691 function _Finalize(p : Pointer; typeInfo : Pointer): Pointer;692 begin693   Result := _FinalizeArray(p, typeInfo, 1);694 end;695 696 function _New(Size : NativeInt; TypeInfo : Pointer): Pointer;697 begin698   GetMem(Result, Size);699   if Result <> nil then700     _Initialize(Result, TypeInfo);701 end;702 703 procedure _Dispose(P : Pointer; TypeInfo : Pointer);704 begin705   _Finalize(P, TypeInfo);706   FreeMem(P);707 end;