mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-07 22:47:59 +02:00
* Variant types: renamed varunicodestring to varustring and changed its value to $102 (for Delphi compatibility), introduced varUStrArg=$73, added some description comments.
* ncal.pas, translate_disp_call: * pass UnicodeString as varUStrArg * do not typecast ordinal consts to Integer, so typecasts in source (if any) are preserved. + test for correct passing of Dispatch method arguments, concludes work on Mantis #17904. git-svn-id: trunk@16456 -
This commit is contained in:
sergei
parent
5f39d255e1
commit
7dd93b1282
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -10751,6 +10751,7 @@ tests/webtbs/tw1780.pp svneol=native#text/plain
|
||||
tests/webtbs/tw17836.pp svneol=native#text/plain
|
||||
tests/webtbs/tw17846.pp svneol=native#text/plain
|
||||
tests/webtbs/tw17862.pp svneol=native#text/plain
|
||||
tests/webtbs/tw17904.pas svneol=native#text/plain
|
||||
tests/webtbs/tw17907/main/main.pas svneol=native#text/plain
|
||||
tests/webtbs/tw17907/test.bat svneol=native#text/plain
|
||||
tests/webtbs/tw17907/unit1/unit0001.pas svneol=native#text/plain
|
||||
|
||||
@ -299,7 +299,6 @@ implementation
|
||||
vardatadef,
|
||||
pvardatadef : tdef;
|
||||
useresult: boolean;
|
||||
byrefpara: boolean;
|
||||
restype: byte;
|
||||
|
||||
names : ansistring;
|
||||
@ -308,7 +307,6 @@ implementation
|
||||
|
||||
function is_byref_para(out assign_type: tdef): boolean;
|
||||
begin
|
||||
// !! This condition is subject to change, see Mantis #17904
|
||||
result:=(assigned(para.parasym) and (para.parasym.varspez in [vs_var,vs_out,vs_constref])) or
|
||||
(variantdispatch and valid_for_var(para.left,false));
|
||||
|
||||
@ -330,6 +328,9 @@ implementation
|
||||
if is_ansistring(sourcedef) then
|
||||
result:=varStrArg
|
||||
else
|
||||
if is_unicodestring(sourcedef) then
|
||||
result:=varUStrArg
|
||||
else
|
||||
if is_interface(sourcedef) then
|
||||
begin
|
||||
{ distinct IDispatch and IUnknown interfaces }
|
||||
@ -376,10 +377,7 @@ implementation
|
||||
inc(namedparacount);
|
||||
|
||||
{ insert some extra casts }
|
||||
if is_constintnode(para.left) and not(is_64bitint(para.left.resultdef)) then
|
||||
inserttypeconv_internal(para.left,s32inttype)
|
||||
|
||||
else if para.left.nodetype=stringconstn then
|
||||
if para.left.nodetype=stringconstn then
|
||||
inserttypeconv_internal(para.left,cwidestringtype)
|
||||
|
||||
{ force automatable boolean type }
|
||||
|
||||
@ -803,6 +803,7 @@ implementation
|
||||
Constants
|
||||
****************************************************************************}
|
||||
|
||||
{ !! Be sure to keep these in sync with ones in rtl/inc/varianth.inc }
|
||||
const
|
||||
varempty = 0;
|
||||
varnull = 1;
|
||||
@ -825,13 +826,15 @@ implementation
|
||||
varlongword = 19;
|
||||
varint64 = 20;
|
||||
varqword = 21;
|
||||
varunicodestr = 22;
|
||||
|
||||
varUndefined = -1;
|
||||
|
||||
varstrarg = $48;
|
||||
varustrarg = $49;
|
||||
|
||||
varstring = $100;
|
||||
varany = $101;
|
||||
varustring = $102;
|
||||
vardefmask = $fff;
|
||||
vararray = $2000;
|
||||
varbyref = $4000;
|
||||
@ -1367,7 +1370,7 @@ implementation
|
||||
function tstringdef.getvardef : longint;
|
||||
const
|
||||
vardef : array[tstringtype] of longint = (
|
||||
varUndefined,varUndefined,varString,varOleStr,varUnicodeStr);
|
||||
varUndefined,varUndefined,varString,varOleStr,varUString);
|
||||
begin
|
||||
result:=vardef[stringtype];
|
||||
end;
|
||||
|
||||
@ -13,6 +13,9 @@
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{ Variant types. Changes to these consts must be synchronized with
|
||||
similar list in compiler code, in implementation part of symdef.pas }
|
||||
const
|
||||
varempty = 0;
|
||||
varnull = 1;
|
||||
@ -40,14 +43,26 @@ const
|
||||
|
||||
varrecord = 36;
|
||||
|
||||
varstrarg = $48;
|
||||
{ The following values never appear as TVarData.VType, but are used in
|
||||
TCallDesc.Args[] as aliases for compiler-specific types.
|
||||
(since it provides only 1 byte per element, actual values won't fit)
|
||||
The choice of values is pretty much arbitrary. }
|
||||
|
||||
varstrarg = $48; { maps to varstring }
|
||||
varustrarg = $49; { maps to varustring }
|
||||
|
||||
{ Compiler-specific variant types (not known to COM) are kept in
|
||||
'pseudo-custom' range of $100-$10E. Real custom types start with $10F. }
|
||||
|
||||
varstring = $100;
|
||||
varany = $101;
|
||||
varustring = $102;
|
||||
vartypemask = $fff;
|
||||
vararray = $2000;
|
||||
varbyref = $4000;
|
||||
|
||||
varword64 = varqword;
|
||||
varuint64 = varqword; // Delphi alias
|
||||
|
||||
type
|
||||
tvartype = word;
|
||||
|
||||
198
tests/webtbs/tw17904.pas
Normal file
198
tests/webtbs/tw17904.pas
Normal file
@ -0,0 +1,198 @@
|
||||
|
||||
{$ifdef fpc}{$mode objfpc}{$h+}{$endif}
|
||||
{$apptype console}
|
||||
|
||||
uses Variants, SysUtils;
|
||||
|
||||
type
|
||||
TTest = class(TCustomVariantType)
|
||||
procedure Clear(var V: TVarData); override;
|
||||
procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;
|
||||
procedure DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer); override;
|
||||
end;
|
||||
|
||||
procedure TTest.Clear(var V: TVarData);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TTest.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TTest.DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
|
||||
var
|
||||
tmp: Word;
|
||||
begin
|
||||
if (CallDesc^.ArgCount =2) and Assigned(Dest) then
|
||||
begin
|
||||
//writeln(HexStr(PPointer(Params)^), ' ', HexStr(PPointer(Params)[1]));
|
||||
WordRec(tmp).Lo := CallDesc^.ArgTypes[0];
|
||||
WordRec(tmp).Hi := CallDesc^.ArgTypes[1];
|
||||
// !! FPC passes args right-to-left, Delphi does same left-to-right
|
||||
// Moreover, IDispatch needs args right-to-left, and Variant Dispatch needs left-to-right. Nice, huh?
|
||||
{$ifdef fpc}
|
||||
tmp := Swap(tmp);
|
||||
{$endif}
|
||||
Variant(Dest^) := tmp;
|
||||
end;
|
||||
end;
|
||||
|
||||
type
|
||||
TTestClass=class
|
||||
u8: byte;
|
||||
u16: word;
|
||||
u32: longword;
|
||||
{$ifdef fpc}
|
||||
u64: qword;
|
||||
{$endif}
|
||||
s8: shortint;
|
||||
s16: smallint;
|
||||
s32: longint;
|
||||
s64: int64;
|
||||
|
||||
cy: currency;
|
||||
|
||||
b: boolean;
|
||||
bb: bytebool;
|
||||
wb: wordbool;
|
||||
lb: longbool;
|
||||
|
||||
sgl: single;
|
||||
dbl: double;
|
||||
ext: extended;
|
||||
dt: TDateTime;
|
||||
|
||||
fsstr: shortstring;
|
||||
fastr: ansistring;
|
||||
fwstr: widestring;
|
||||
{$ifdef fpc}
|
||||
fustr: unicodestring;
|
||||
{$endif}
|
||||
|
||||
fvar: Variant;
|
||||
fintf: IInterface;
|
||||
fdisp: IDispatch;
|
||||
|
||||
property u8prop: Byte read u8;
|
||||
property u16prop: Word read u16;
|
||||
property u32prop: LongWord read u32;
|
||||
{$ifdef fpc}
|
||||
property u64prop: QWord read u64;
|
||||
{$endif}
|
||||
property s8prop: ShortInt read s8;
|
||||
property s16prop: SmallInt read s16;
|
||||
property s32prop: LongInt read s32;
|
||||
property s64prop: Int64 read s64;
|
||||
|
||||
property cyprop: currency read cy;
|
||||
property bprop: boolean read b;
|
||||
property bbprop: bytebool read bb;
|
||||
property wbprop: wordbool read wb;
|
||||
property lbprop: longbool read lb;
|
||||
|
||||
property sglprop: single read sgl;
|
||||
property dblprop: double read dbl;
|
||||
property extprop: extended read ext;
|
||||
property dtprop: TDateTime read dt;
|
||||
|
||||
property varprop: Variant read fvar;
|
||||
property intfprop: IInterface read fintf;
|
||||
property dispprop: IDispatch read fdisp;
|
||||
|
||||
property sstr: shortstring read fsstr;
|
||||
property astr: ansistring read fastr;
|
||||
property wstr: widestring read fwstr;
|
||||
{$ifdef fpc}
|
||||
property ustr: unicodestring read fustr;
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
var
|
||||
cv: TCustomVariantType;
|
||||
code: Integer;
|
||||
cl: TTestClass;
|
||||
v: Variant;
|
||||
|
||||
// using negative values of Expected to check that arg is passed by-value only
|
||||
procedure test(const id: string; const act: Variant; expected: Integer);
|
||||
var
|
||||
tmp: word;
|
||||
absexp: Integer;
|
||||
begin
|
||||
tmp := act;
|
||||
absexp := abs(expected);
|
||||
write(id, WordRec(tmp).Lo,', ', WordRec(tmp).Hi);
|
||||
if (expected >= 0) and (WordRec(tmp).Lo <> (expected or $80)) then
|
||||
begin
|
||||
write(' BYREF failed');
|
||||
Code := Code or 1;
|
||||
end;
|
||||
if WordRec(tmp).Hi <> absexp then
|
||||
begin
|
||||
write(' BYVAL failed');
|
||||
Code := Code or 2;
|
||||
end;
|
||||
writeln;
|
||||
end;
|
||||
|
||||
begin
|
||||
Code := 0;
|
||||
cv := TTest.Create;
|
||||
cl := TTestClass.Create;
|
||||
TVarData(v).vType := cv.VarType;
|
||||
|
||||
test('u8: ', v.foo(cl.u8, cl.u8prop), varbyte);
|
||||
|
||||
test('u16: ', v.foo(cl.u16, cl.u16prop), varword); // (Uncertain) D7: treated as Integer
|
||||
test('u32: ', v.foo(cl.u32, cl.u32prop), varlongword); // (Uncertain) D7: treated as Integer ByRef
|
||||
test('s8: ', v.foo(cl.s8, cl.s8prop), varshortint); // (Uncertain) D7: treated as Integer
|
||||
|
||||
test('s16: ', v.foo(cl.s16, cl.s16prop), varsmallint);
|
||||
test('s32: ', v.foo(cl.s32, cl.s32prop), varinteger);
|
||||
test('s64: ', v.foo(cl.s64, cl.s64prop), varint64);
|
||||
{$ifdef fpc}
|
||||
test('u64: ', v.foo(cl.u64, cl.u64prop), varword64);
|
||||
{$endif}
|
||||
|
||||
test('wordbool:', v.foo(cl.wb, cl.wbprop), varBoolean);
|
||||
test('curncy: ', v.foo(cl.cy, cl.cyprop), varCurrency);
|
||||
|
||||
test('single: ', v.foo(cl.sgl, cl.sglprop), varSingle);
|
||||
test('double: ', v.foo(cl.dbl, cl.dblprop), varDouble);
|
||||
test('extended:', v.foo(cl.ext, cl.extprop), -varDouble); // not a COM type, passed by value
|
||||
|
||||
test('date: ', v.foo(cl.dt, cl.dtprop), varDate);
|
||||
|
||||
test('ansistr: ', v.foo(cl.fastr, cl.astr), varStrArg);
|
||||
test('widestr: ', v.foo(cl.fwstr, cl.wstr), varOleStr);
|
||||
{$ifdef fpc}
|
||||
test('unistr: ', v.foo(cl.fustr, cl.ustr), varUStrArg);
|
||||
{$endif}
|
||||
test('variant: ', v.foo(cl.fvar, cl.varprop), varVariant);
|
||||
|
||||
test('IUnknown:', v.foo(cl.fintf, cl.intfprop), varUnknown);
|
||||
test('IDispatch:', v.foo(cl.fdisp, cl.dispprop), varDispatch);
|
||||
|
||||
// not an COM type, passed by value; Delphi uses varStrArg
|
||||
test('shortstr:', v.foo(cl.fsstr, cl.sstr), -varOleStr);
|
||||
// not an COM type, passed by value
|
||||
test('longbool:', v.foo(cl.lb, cl.lbprop), -varBoolean);
|
||||
|
||||
// typecasted ordinals (only one arg is actually used)
|
||||
test('u8+cast: ', v.foo(byte(55), byte(55)), -varByte);
|
||||
test('u16+cast:', v.foo(word(55), word(55)), -varWord);
|
||||
test('u32+cast:', v.foo(longword(55), longword(55)), -varLongWord);
|
||||
{$ifdef fpc}
|
||||
test('u64+cast:', v.foo(qword(55), qword(55)), -varQWord);
|
||||
{$endif}
|
||||
test('s8+cast:', v.foo(shortint(55), shortint(55)), -varShortInt);
|
||||
test('s16+cast:', v.foo(smallint(55), smallint(55)), -varSmallInt);
|
||||
test('s32+cast:', v.foo(longint(55), longint(55)), -varInteger);
|
||||
test('s64+cast:', v.foo(int64(55), int64(55)), -varInt64);
|
||||
|
||||
cl.Free;
|
||||
if Code <> 0 then
|
||||
writeln('Errors: ', Code);
|
||||
Halt(Code);
|
||||
|
||||
end.
|
||||
Loading…
Reference in New Issue
Block a user