paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-27 20:59:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* variants.pp, modified TCustomVariantType constructors to they pass basic tests (tests/units/variants/tcustomvariant.pp)

Browse Source 
* Changed allowed custom VarType range to $10F..$FFF (as specified in Delphi documentation).

git-svn-id: trunk@16323 -
This commit is contained in:
sergei 2010-11-10 16:27:23 +00:00
parent a360f4c955
commit bd15329d38
1 changed files with 40 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
rtl/inc/variants.pp
View File

@ -265,7 +265,7 @@ type
CallDesc: PCallDesc; Params: Pointer); cdecl;
Const
CMaxNumberOfCustomVarTypes = $06FF;
CMaxNumberOfCustomVarTypes = $0EFF;
CMinVarType = $0100;
CMaxVarType = CMinVarType + CMaxNumberOfCustomVarTypes;
CIncVarType = $000F;
@ -367,6 +367,7 @@ uses
var
customvarianttypes : array of TCustomVariantType;
customvarianttypelock : trtlcriticalsection;
customvariantcurrtype : LongInt;
const
{ all variants for which vType and varComplexType = 0 do not require
@ -3812,24 +3813,53 @@ begin
end;
constructor TCustomVariantType.Create;
procedure RegisterCustomVariantType(obj: TCustomVariantType; RequestedVarType: TVarType;
UseFirstAvailable: Boolean);
var
index,L: Integer;
begin
inherited Create;
EnterCriticalSection(customvarianttypelock);
try
SetLength(customvarianttypes,Length(customvarianttypes)+1);
customvarianttypes[High(customvarianttypes)]:=self;
FVarType:=CMinVarType+High(customvarianttypes);
L:=Length(customvarianttypes);
if UseFirstAvailable then
begin
repeat
inc(customvariantcurrtype);
if customvariantcurrtype>=CMaxVarType then
raise EVariantError.Create(SVarTypeTooManyCustom);
until ((customvariantcurrtype-CMinVarType)>=L) or
(customvarianttypes[customvariantcurrtype-CMinVarType]=nil);
RequestedVarType:=customvariantcurrtype;
end
else if (RequestedVarType<CFirstUserType) or (RequestedVarType>CMaxVarType) then
raise EVariantError.CreateFmt(SVarTypeOutOfRangeWithPrefix, ['$', RequestedVarType]);
index:=RequestedVarType-CMinVarType;
if index>=L then
SetLength(customvarianttypes,L+1);
if Assigned(customvarianttypes[index]) then
begin
if customvarianttypes[index]=InvalidCustomVariantType then
raise EVariantError.CreateFmt(SVarTypeNotUsableWithPrefix, ['$', RequestedVarType])
else
raise EVariantError.CreateFmt(SVarTypeAlreadyUsedWithPrefix,
['$', RequestedVarType, customvarianttypes[index].ClassName]);
end;
customvarianttypes[index]:=obj;
obj.FVarType:=RequestedVarType;
finally
LeaveCriticalSection(customvarianttypelock);
end;
end;
constructor TCustomVariantType.Create;
begin
RegisterCustomVariantType(Self,0,True);
end;
constructor TCustomVariantType.Create(RequestedVarType: TVarType);
begin
FVarType:=RequestedVarType;
RegisterCustomVariantType(Self,RequestedVarType,False);
end;
@ -4450,6 +4480,8 @@ var
Initialization
InitCriticalSection(customvarianttypelock);
// start with one-less value, so first increment yields CFirstUserType
customvariantcurrtype:=CFirstUserType-1;
SetSysVariantManager;
SetClearVarToEmptyParam(TVarData(EmptyParam));
VarClearProc:=@DoVarClear;