diff --git a/.gitattributes b/.gitattributes index 97061bcc0e..db74aabdb8 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/compiler/ncal.pas b/compiler/ncal.pas index d464bc6fc7..6668e24ad4 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -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 } diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 8ff02d47ef..727a3f4e4c 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -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; diff --git a/rtl/inc/varianth.inc b/rtl/inc/varianth.inc index 2e2cd4d65a..c52b0615df 100644 --- a/rtl/inc/varianth.inc +++ b/rtl/inc/varianth.inc @@ -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; diff --git a/tests/webtbs/tw17904.pas b/tests/webtbs/tw17904.pas new file mode 100644 index 0000000000..06a01e7b2b --- /dev/null +++ b/tests/webtbs/tw17904.pas @@ -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. \ No newline at end of file