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

* fixed variantarrays for 64 bit systems after the changes in 2.2.0 to

Browse Source 
turn variantarray indices into longints
  * extended tw9161 to also test storing and retrieving dynamic arrays
    in/from variant arrays

git-svn-id: trunk@12713 -
This commit is contained in:
Jonas Maebe 2009-02-08 00:24:03 +00:00
parent 31756489a2
commit 95431c57f5
5 changed files with 25 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
rtl/inc/compproc.inc
View File

@ -518,8 +518,8 @@ function fpc_variant_to_interface(const v : variant) : iinterface;compilerproc;
function fpc_interface_to_variant(const i : iinterface) : variant;compilerproc;
function fpc_variant_to_idispatch(const v : variant) : idispatch;compilerproc;
function fpc_idispatch_to_variant(const i : idispatch) : variant;compilerproc;
procedure fpc_vararray_get(var d : variant;const s : variant;indices : psizeint;len : sizeint);compilerproc;
procedure fpc_vararray_put(var d : variant;const s : variant;indices : psizeint;len : sizeint);compilerproc;
procedure fpc_vararray_get(var d : variant;const s : variant;indices : plongint;len : sizeint);compilerproc;
procedure fpc_vararray_put(var d : variant;const s : variant;indices : plongint;len : sizeint);compilerproc;
procedure fpc_dispinvoke_variant(dest : pvardata;const source : tvardata; calldesc : pcalldesc;params : pointer);compilerproc;
{$endif FPC_HAS_FEATURE_VARIANTS}

8
rtl/inc/variant.inc
View File

@ -75,13 +75,13 @@ Procedure fpc_write_text_variant(Len : Longint;var f : Text;const v : variant);
end;
procedure fpc_vararray_get(var d : variant;const s : variant;indices : psizeint;len : sizeint);compilerproc;
procedure fpc_vararray_get(var d : variant;const s : variant;indices : plongint;len : sizeint);compilerproc;
begin
d:=variantmanager.vararrayget(s,len,indices);
end;
procedure fpc_vararray_put(var d : variant;const s : variant;indices : psizeint;len : sizeint);compilerproc;
procedure fpc_vararray_put(var d : variant;const s : variant;indices : plongint;len : sizeint);compilerproc;
begin
variantmanager.vararrayput(d,s,len,indices);
end;
@ -637,7 +637,7 @@ procedure VarArrayRedim(var A: Variant; HighBound: SizeInt);
variantmanager.vararrayredim(a,highbound);
end;
procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of SizeInt);
procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of Longint);
begin
if Length(Indices)>0 then
variantmanager.vararrayput(A, Value, Length(Indices), @Indices[0])
@ -646,7 +646,7 @@ procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array
end;
function VarArrayGet(const A: Variant; const Indices: array of SizeInt): Variant;
function VarArrayGet(const A: Variant; const Indices: array of Longint): Variant;
begin
if Length(Indices)>0 then
Result:=variantmanager.vararrayget(A, Length(Indices), @Indices[0])

8
rtl/inc/varianth.inc
View File

@ -193,9 +193,9 @@ type
calldesc : pcalldesc;params : pointer);cdecl;
vararrayredim : procedure(var a : variant;highbound : SizeInt);
vararrayget : function(const a : variant;indexcount : SizeInt;indices : PSizeInt) : variant;cdecl;
vararrayget : function(const a : variant;indexcount : SizeInt;indices : plongint) : variant;cdecl;
vararrayput: procedure(var a : variant; const value : variant;
indexcount : SizeInt;indices : PSizeInt);cdecl;
indexcount : SizeInt;indices : plongint);cdecl;
writevariant : function(var t : text;const v : variant;width : longint) : Pointer;
write0Variant : function(var t : text;const v : Variant) : Pointer;
end;
@ -363,8 +363,8 @@ operator <=(const op1,op2 : variant) dest : boolean;{$ifdef SYSTEMINLINE}inline;
{ variant helpers }
procedure VarArrayRedim(var A: Variant; HighBound: SizeInt);
procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of SizeInt);
function VarArrayGet(const A: Variant; const Indices: array of SizeInt): Variant;
procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of Longint);
function VarArrayGet(const A: Variant; const Indices: array of Longint): Variant;
procedure VarCast(var dest : variant;const source : variant;vartype : longint);
{**********************************************************************

8
rtl/inc/variants.pp
View File

@ -2542,7 +2542,7 @@ begin
end;
function sysvararrayget(const a : Variant;indexcount : SizeInt;indices : psizeint) : Variant;cdecl;
function sysvararrayget(const a : Variant;indexcount : SizeInt;indices : plongint) : Variant;cdecl;
var
src : TVarData;
p : pvararray;
@ -2583,7 +2583,7 @@ begin
end;
procedure sysvararrayput(var a : Variant; const value : Variant;indexcount : SizeInt;indices : psizeint);cdecl;
procedure sysvararrayput(var a : Variant; const value : Variant;indexcount : SizeInt;indices : plongint);cdecl;
var
Dest : TVarData;
p : pvararray;
@ -3390,7 +3390,7 @@ procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: P
VarClear(temp);
end;
dynarriter.next;
variantmanager.VarArrayPut(V,temp,Dims,PSizeInt(iter.Coords));
variantmanager.VarArrayPut(V,temp,Dims,PLongint(iter.Coords));
until not(iter.next);
finally
iter.done;
@ -3444,7 +3444,7 @@ procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo:
dynarriter.init(DynArray,TypeInfo,VarArrayDims,dynarraybounds);
if not iter.AtEnd then
repeat
temp:=variantmanager.VarArrayGet(V,VarArrayDims,PSizeInt(iter.Coords));
temp:=variantmanager.VarArrayGet(V,VarArrayDims,PLongint(iter.Coords));
case dynarrvartype of
varSmallInt:
PSmallInt(dynarriter.data)^:=temp;

11
tests/webtbs/tw9161.pp
View File

@ -4,6 +4,7 @@ uses
{$endif}
variants,sysutils;
var a:variant;
x,y: array of byte;
begin
a:=VarArrayCreate([0,2,0,2],varVariant);
if VarArrayDimCount(a)<>2 then
@ -14,6 +15,16 @@ begin
a[2,1]:='asdf';
if VarArrayGet(a,[2,1])<>'asdf' then
halt(2);
setlength(x,3);
x[0]:=77;
x[1]:=88;
x[2]:=99;
a[2,2]:=x;
y:=VarArrayGet(a,[2,2]);
if (y[0]<>x[0]) or
(y[1]<>x[1]) or
(y[2]<>x[2]) then
halt(3);
a:='';
writeln('ok');
end.