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

* Merged XPCom branch into trunk, added support for constref and changed

Browse Source 
the IInterface implementation to be XPCom-compatible
--- Merging r15997 through r16179 into '.':
U    rtl/inc/variants.pp
U    rtl/inc/objpash.inc
U    rtl/inc/objpas.inc
U    rtl/objpas/classes/persist.inc
U    rtl/objpas/classes/compon.inc
U    rtl/objpas/classes/classesh.inc
A    tests/test/tconstref1.pp
A    tests/test/tconstref2.pp
A    tests/test/tconstref3.pp
U    tests/test/tinterface4.pp
A    tests/test/tconstref4.pp
U    tests/webtbs/tw10897.pp
U    tests/webtbs/tw4086.pp
U    tests/webtbs/tw15363.pp
U    tests/webtbs/tw2177.pp
U    tests/webtbs/tw16592.pp
U    tests/tbs/tb0546.pp
U    compiler/sparc/cpupara.pas
U    compiler/i386/cpupara.pas
U    compiler/pdecsub.pas
U    compiler/symdef.pas
U    compiler/powerpc/cpupara.pas
U    compiler/avr/cpupara.pas
U    compiler/browcol.pas
U    compiler/defcmp.pas
U    compiler/powerpc64/cpupara.pas
U    compiler/ncgrtti.pas
U    compiler/x86_64/cpupara.pas
U    compiler/opttail.pas
U    compiler/htypechk.pas
U    compiler/tokens.pas
U    compiler/objcutil.pas
U    compiler/ncal.pas
U    compiler/symtable.pas
U    compiler/symsym.pas
U    compiler/m68k/cpupara.pas
U    compiler/regvars.pas
U    compiler/arm/cpupara.pas
U    compiler/symconst.pas
U    compiler/mips/cpupara.pas
U    compiler/paramgr.pas
U    compiler/psub.pas
U    compiler/pdecvar.pas
U    compiler/dbgstabs.pas
U    compiler/options.pas
U    packages/fcl-fpcunit/src/testutils.pp

git-svn-id: trunk@16180 -
This commit is contained in:
joost 2010-10-17 20:58:22 +00:00
parent 8304d2c1c5
commit 07bf44517c
47 changed files with 330 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -9167,6 +9167,10 @@ tests/test/tclassinfo1.pp svneol=native#text/pascal
tests/test/tclrprop.pp svneol=native#text/plain
tests/test/tcmp.pp svneol=native#text/plain
tests/test/tcmp0.pp svneol=native#text/plain
tests/test/tconstref1.pp svneol=native#text/pascal
tests/test/tconstref2.pp svneol=native#text/pascal
tests/test/tconstref3.pp svneol=native#text/pascal
tests/test/tconstref4.pp svneol=native#text/pascal
tests/test/tcstring1.pp svneol=native#text/pascal
tests/test/tcstring2.pp svneol=native#text/pascal
tests/test/tdel1.pp svneol=native#text/plain

2
compiler/arm/cpupara.pas
View File

@ -169,7 +169,7 @@ unit cpupara;
function tarmparamanager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;
begin
result:=false;
if varspez in [vs_var,vs_out] then
if varspez in [vs_var,vs_out,vs_constref] then
begin
result:=true;
exit;

2
compiler/avr/cpupara.pas
View File

@ -155,7 +155,7 @@ unit cpupara;
function tavrparamanager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;
begin
result:=false;
if varspez in [vs_var,vs_out] then
if varspez in [vs_var,vs_out,vs_constref] then
begin
result:=true;
exit;

9
compiler/browcol.pas
View File

@ -1343,10 +1343,11 @@ end;
CurName:=': '+GetDefinitionStr(dc.vardef);
CurName:=dc.RealName+CurName;
case dc.varspez of
vs_Value : ;
vs_Const : CurName:='const '+CurName;
vs_Var : CurName:='var '+CurName;
vs_Out : CurName:='out '+CurName;
vs_Value : ;
vs_Const : CurName:='const '+CurName;
vs_Var : CurName:='var '+CurName;
vs_Out : CurName:='out '+CurName;
vs_Constref : CurName:='constref '+CurName;
end;
if Count>0 then
CurName:='; '+CurName;

2
compiler/dbgstabs.pas
View File

@ -441,6 +441,8 @@ implementation
argnames:=argnames+'5const';
vs_out :
argnames:=argnames+'3out';
vs_constref :
argnames:=argnames+'8constref';
end;
end
else

4
compiler/defcmp.pas
View File

@ -1669,8 +1669,8 @@ implementation
if (
not(cpo_ignorevarspez in cpoptions) and
(currpara1.varspez<>currpara2.varspez) and
((currpara1.varspez in [vs_var,vs_out]) or
(currpara2.varspez in [vs_var,vs_out]))
((currpara1.varspez in [vs_var,vs_out,vs_constref]) or
(currpara2.varspez in [vs_var,vs_out,vs_constref]))
) then
exit;
eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,

2
compiler/htypechk.pas
View File

@ -1399,7 +1399,7 @@ implementation
else
exit;
{ read-only variable? }
if (tabstractvarsym(tloadnode(hp).symtableentry).varspez=vs_const) then
if (tabstractvarsym(tloadnode(hp).symtableentry).varspez in [vs_const,vs_constref]) then
begin
{ allow p^:= constructions with p is const parameter }
if gotderef or gotdynarray or (Valid_Const in opts) or

4
compiler/i386/cpupara.pas
View File

@ -152,8 +152,8 @@ unit cpupara;
function ti386paramanager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;
begin
result:=false;
{ var,out always require address }
if varspez in [vs_var,vs_out] then
{ var,out,constref always require address }
if varspez in [vs_var,vs_out,vs_constref] then
begin
result:=true;
exit;

4
compiler/m68k/cpupara.pas
View File

@ -149,8 +149,8 @@ unit cpupara;
function tm68kparamanager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;
begin
result:=false;
{ var,out always require address }
if varspez in [vs_var,vs_out] then
{ var,out,constref always require address }
if varspez in [vs_var,vs_out,vs_constref] then
begin
result:=true;
exit;

4
compiler/mips/cpupara.pas
View File

@ -110,8 +110,8 @@ implementation
function tMIPSELparamanager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;
begin
result:=false;
{ var,out always require address }
if varspez in [vs_var,vs_out] then
{ var,out,constref always require address }
if varspez in [vs_var,vs_out,vs_constref] then
begin
result:=true;
exit;

10
compiler/ncal.pas
View File

@ -461,7 +461,7 @@ implementation
internalerror(200611041);
end;
dispatchbyref:=(assigned(para.parasym) and (para.parasym.varspez in [vs_var,vs_out])) or
dispatchbyref:=(assigned(para.parasym) and (para.parasym.varspez in [vs_var,vs_out,vs_constref])) or
(para.left.resultdef.typ in [variantdef]);
{ assign the argument/parameter to the temporary location }
@ -836,7 +836,7 @@ implementation
if (cs_strict_var_strings in current_settings.localswitches) and
is_shortstring(left.resultdef) and
is_shortstring(parasym.vardef) and
(parasym.varspez in [vs_out,vs_var]) and
(parasym.varspez in [vs_out,vs_var,vs_constref]) and
not(is_open_string(parasym.vardef)) and
not(equal_defs(left.resultdef,parasym.vardef)) then
begin
@ -878,6 +878,7 @@ implementation
case parasym.varspez of
vs_var,
vs_constref,
vs_out :
begin
if not valid_for_formal_var(left,true) then
@ -897,7 +898,7 @@ implementation
valid_for_var(left,true);
end;
if parasym.varspez in [vs_var,vs_out] then
if parasym.varspez in [vs_var,vs_out,vs_constref] then
set_unique(left);
{ When the address needs to be pushed then the register is
@ -933,7 +934,8 @@ implementation
set_varstate(left,vs_written,[]);
set_varstate(left,vs_readwritten,[]);
end;
vs_var :
vs_var,
vs_constref:
set_varstate(left,vs_readwritten,[vsf_must_be_valid,vsf_use_hints]);
else
set_varstate(left,vs_read,[vsf_must_be_valid]);

9
compiler/ncgrtti.pas
View File

@ -662,10 +662,11 @@ implementation
if not(vo_is_hidden_para in parasym.varoptions) then
begin
case parasym.varspez of
vs_value: paraspec := 0;
vs_const: paraspec := pfConst;
vs_var : paraspec := pfVar;
vs_out : paraspec := pfOut;
vs_value : paraspec := 0;
vs_const : paraspec := pfConst;
vs_var : paraspec := pfVar;
vs_out : paraspec := pfOut;
vs_constref: paraspec := pfConstRef;
end;
{ Kylix also seems to always add both pfArray and pfReference
in this case

2
compiler/objcutil.pas
View File

@ -225,7 +225,7 @@ end;
{ addencodedtype always assumes a value parameter, so add
a pointer indirection for var/out parameters. }
if not paramanager.push_addr_param(vs_value,vs.vardef,pocall_cdecl) and
(vs.varspez in [vs_var,vs_out]) then
(vs.varspez in [vs_var,vs_out,vs_constref]) then
result:=result+'^';
{ Add the parameter type. }
if not addencodedtype(vs.vardef,ris_initial,false,result,founderror) then

1
compiler/options.pas
View File

@ -2411,6 +2411,7 @@ begin
def_system_macro('FPC_STRTOSHORTSTRINGPROC');
def_system_macro('FPC_OBJFPC_EXTENDED_IF');
def_system_macro('FPC_HAS_OPERATOR_ENUMERATOR');
def_system_macro('FPC_HAS_CONSTREF');
{$if defined(x86) or defined(powerpc) or defined(powerpc64)}
def_system_macro('FPC_HAS_INTERNAL_ABS_LONG');
{$endif}

2
compiler/opttail.pas
View File

@ -185,7 +185,7 @@ unit opttail;
{ check if the parameters actually would support tail recursion elimination }
for i:=0 to p.paras.count-1 do
with tparavarsym(p.paras[i]) do
if (varspez in [vs_out,vs_var]) or
if (varspez in [vs_out,vs_var,vs_constref]) or
((varspez=vs_const) and
(paramanager.push_addr_param(varspez,vardef,p.proccalloption)) or
{ parameters requiring tables are too complicated to handle

1
compiler/paramgr.pas
View File

@ -185,6 +185,7 @@ implementation
begin
push_size:=-1;
case varspez of
vs_constref,
vs_out,
vs_var :
push_size:=sizeof(pint);

5
compiler/pdecsub.pas
View File

@ -473,6 +473,9 @@ implementation
if (m_out in current_settings.modeswitches) and
try_to_consume(_OUT) then
varspez:=vs_out
else
if try_to_consume(_CONSTREF) then
varspez:=vs_constref
else
if (m_mac in current_settings.modeswitches) and
try_to_consume(_POINTPOINTPOINT) then
@ -592,7 +595,7 @@ implementation
if is_shortstring(hdef) then
begin
case varspez of
vs_var,vs_out:
vs_var,vs_out,vs_constref:
begin
{ not 100% Delphi-compatible: type xstr=string[255] cannot
become an openstring there, while here it can }

2
compiler/pdecvar.pas
View File

@ -363,6 +363,8 @@ implementation
varspez:=vs_var
else if try_to_consume(_CONST) then
varspez:=vs_const
else if try_to_consume(_CONSTREF) then
varspez:=vs_constref
else if (m_out in current_settings.modeswitches) and try_to_consume(_OUT) then
varspez:=vs_out
else

4
compiler/powerpc/cpupara.pas
View File

@ -176,8 +176,8 @@ unit cpupara;
function tppcparamanager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;
begin
result:=false;
{ var,out always require address }
if varspez in [vs_var,vs_out] then
{ var,out,constref always require address }
if varspez in [vs_var,vs_out,vs_constref] then
begin
result:=true;
exit;

4
compiler/powerpc64/cpupara.pas
View File

@ -159,8 +159,8 @@ function tppcparamanager.push_addr_param(varspez: tvarspez; def: tdef;
calloption: tproccalloption): boolean;
begin
result := false;
{ var,out always require address }
if varspez in [vs_var, vs_out] then
{ var,out,constref always require address }
if varspez in [vs_var, vs_out, vs_constref] then
begin
result := true;
exit;

2
compiler/psub.pas
View File

@ -1363,7 +1363,7 @@ implementation
case currpara.vardef.typ of
formaldef :
begin
if (currpara.varspez in [vs_out,vs_var,vs_const]) then
if (currpara.varspez in [vs_out,vs_var,vs_const,vs_constref]) then
begin
Message1(parser_w_not_supported_for_inline,'formal parameter');
Message(parser_w_inlining_disabled);

2
compiler/regvars.pas
View File

@ -69,7 +69,7 @@ implementation
begin
parasym:=pboolean(arg)^;
if (tsym(p).typ=varsym) and ((tvarsym(p).varregable <> vr_none) or
((tvarsym(p).varspez in [vs_var,vs_const,vs_out]) and
((tvarsym(p).varspez in [vs_var,vs_const,vs_out,vs_constref]) and
paramanager.push_addr_param(tvarsym(p).varspez,tvarsym(p).vardef,current_procinfo.procdef.proccalloption))) and
not tvarsym(p).vardef.needs_inittable then
begin

4
compiler/sparc/cpupara.pas
View File

@ -111,8 +111,8 @@ implementation
function tsparcparamanager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;
begin
result:=false;
{ var,out always require address }
if varspez in [vs_var,vs_out] then
{ var,out,constref always require address }
if varspez in [vs_var,vs_out,vs_constref] then
begin
result:=true;
exit;

3
compiler/symconst.pas
View File

@ -101,6 +101,7 @@ const
pfAddress = 8;
pfReference= 16;
pfOut = 32;
pfConstRef = 64;
unknown_level = 0;
main_program_level = 1;
@ -483,7 +484,7 @@ type
vs_referred_not_inited,vs_written,vs_readwritten
);
tvarspez = (vs_value,vs_const,vs_var,vs_out);
tvarspez = (vs_value,vs_const,vs_var,vs_out,vs_constref);
absolutetyp = (tovar,toasm,toaddr);

2
compiler/symdef.pas
View File

@ -2948,6 +2948,8 @@ implementation
s:=s+'const ';
vs_out :
s:=s+'out ';
vs_constref :
s:=s+'constref ';
end;
if hp.univpara then
s:=s+'univ ';

2
compiler/symsym.pas
View File

@ -1402,7 +1402,7 @@ implementation
constructor tparavarsym.create(const n : string;nr:word;vsp:tvarspez;def:tdef;vopts:tvaroptions);
begin
inherited create(paravarsym,n,vsp,def,vopts);
if (vsp in [vs_var,vs_value,vs_const]) then
if (vsp in [vs_var,vs_value,vs_const,vs_constref]) then
varstate := vs_initialised;
paranr:=nr;
paraloc[calleeside].init;

2
compiler/symtable.pas
View File

@ -608,7 +608,7 @@ implementation
begin
if (tsym(sym).owner.symtabletype=parasymtable) then
begin
if not(tabstractvarsym(sym).varspez in [vs_var,vs_out]) and
if not(tabstractvarsym(sym).varspez in [vs_var,vs_out,vs_constref]) and
not(vo_is_funcret in tabstractvarsym(sym).varoptions) then
MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_only_set,tsym(sym).prettyname)
end

2
compiler/tokens.pas
View File

@ -201,6 +201,7 @@ type
_ABSOLUTE,
_ABSTRACT,
_BASESYSV,
_CONSTREF,
_CONTAINS,
_CONTINUE,
_CPPCLASS,
@ -463,6 +464,7 @@ const
(str:'ABSOLUTE' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'ABSTRACT' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'BASESYSV' ;special:false;keyword:m_none;op:NOTOKEN), { Syscall variation on MorphOS }
(str:'CONSTREF' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'CONTAINS' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'CONTINUE' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'CPPCLASS' ;special:false;keyword:m_fpc;op:NOTOKEN),

4
compiler/x86_64/cpupara.pas
View File

@ -644,8 +644,8 @@ unit cpupara;
numclasses: longint;
begin
result:=false;
{ var,out always require address }
if varspez in [vs_var,vs_out] then
{ var,out,constref always require address }
if varspez in [vs_var,vs_out,vs_constref] then
begin
result:=true;
exit;

12
packages/fcl-fpcunit/src/testutils.pp
View File

@ -26,9 +26,9 @@ type
TNoRefCountObject = class(TObject, IInterface)
protected
{ IInterface }
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function QueryInterface(constref IID: TGUID; out Obj): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
end;
{$M-}
@ -38,18 +38,18 @@ procedure GetMethodList( AClass: TClass; AList: TStrings ); overload;
implementation
function TNoRefCountObject.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function TNoRefCountObject.QueryInterface(constref IID: TGUID; out Obj): HResult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
if GetInterface(IID, Obj) then Result := 0
else Result := HRESULT($80004002);
end;
function TNoRefCountObject._AddRef: Integer;stdcall;
function TNoRefCountObject._AddRef: Integer;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
Result := -1;
end;
function TNoRefCountObject._Release: Integer;stdcall;
function TNoRefCountObject._Release: Integer;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
Result := -1;
end;

14
rtl/inc/objpas.inc
View File

@ -967,7 +967,7 @@
****************************************************************************}
function TInterfacedObject.QueryInterface(
const iid : tguid;out obj) : longint;stdcall;
{$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
if getinterface(iid,obj) then
@ -976,13 +976,13 @@
result:=longint(E_NOINTERFACE);
end;
function TInterfacedObject._AddRef : longint;stdcall;
function TInterfacedObject._AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
_addref:=interlockedincrement(frefcount);
end;
function TInterfacedObject._Release : longint;stdcall;
function TInterfacedObject._Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
_Release:=interlockeddecrement(frefcount);
@ -1026,19 +1026,19 @@
end;
function TAggregatedObject.QueryInterface(
const iid : tguid;out obj) : longint;stdcall;
{$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
Result := IUnknown(fcontroller).QueryInterface(iid, obj);
end;
function TAggregatedObject._AddRef : longint;stdcall;
function TAggregatedObject._AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
Result := IUnknown(fcontroller)._AddRef;
end;
function TAggregatedObject._Release : longint;stdcall;
function TAggregatedObject._Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
Result := IUnknown(fcontroller)._Release;
@ -1055,7 +1055,7 @@
****************************************************************************}
function TContainedObject.QueryInterface(
const iid : tguid;out obj) : longint; stdcall;
{$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
if getinterface(iid,obj) then

20
rtl/inc/objpash.inc
View File

@ -243,9 +243,9 @@
IUnknown = interface
['{00000000-0000-0000-C000-000000000046}']
function QueryInterface(const iid : tguid;out obj) : longint;stdcall;
function _AddRef : longint;stdcall;
function _Release : longint;stdcall;
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
end;
IInterface = IUnknown;
@ -283,9 +283,9 @@
protected
frefcount : longint;
{ implement methods of IUnknown }
function QueryInterface(const iid : tguid;out obj) : longint;stdcall;
function _AddRef : longint;stdcall;
function _Release : longint;stdcall;
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
public
procedure AfterConstruction;override;
procedure BeforeDestruction;override;
@ -300,9 +300,9 @@
function GetController: IUnknown;
protected
{ implement methods of IUnknown }
function QueryInterface(const iid : tguid;out obj) : longint;stdcall;
function _AddRef : longint;stdcall;
function _Release : longint;stdcall;
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
public
constructor Create(const aController: IUnknown);
property Controller : IUnknown read GetController;
@ -310,7 +310,7 @@
TContainedObject = class(TAggregatedObject,IInterface)
protected
function QueryInterface(const iid : tguid;out obj) : longint;virtual; stdcall;
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
end;
{ some pointer definitions }

12
rtl/inc/variants.pp
View File

@ -161,9 +161,9 @@ type
private
FVarType: TVarType;
protected
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
procedure SimplisticClear(var V: TVarData);
procedure SimplisticCopy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean = False);
procedure RaiseInvalidOp;
@ -3575,19 +3575,19 @@ function Null: Variant; // Null standard constant
---------------------------------------------------------------------}
{$warnings off}
function TCustomVariantType.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function TCustomVariantType.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
NotSupported('TCustomVariantType.QueryInterface');
end;
function TCustomVariantType._AddRef: Integer; stdcall;
function TCustomVariantType._AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
NotSupported('TCustomVariantType._AddRef');
end;
function TCustomVariantType._Release: Integer; stdcall;
function TCustomVariantType._Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
NotSupported('TCustomVariantType._Release');
end;

12
rtl/objpas/classes/classesh.inc
View File

@ -403,10 +403,10 @@ type
FOwnerInterface: IInterface;
protected
{ IInterface }
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
public
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
procedure AfterConstruction; override;
end;
@ -1630,9 +1630,9 @@ type
procedure ValidateContainer(AComponent: TComponent); dynamic;
procedure ValidateInsert(AComponent: TComponent); dynamic;
{ IUnknown }
function QueryInterface(const IID: TGUID; out Obj): Hresult; virtual; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): Hresult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function iicrGetComponent: TComponent;
{ IDispatch }
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;

6
rtl/objpas/classes/compon.inc
View File

@ -652,7 +652,7 @@ begin
Result := False;
end;
function TComponent.QueryInterface(const IID: TGUID; out Obj): HResult;stdcall;
function TComponent.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
if Assigned(VCLComObject) then
Result := IVCLComObject(VCLComObject).QueryInterface(IID, Obj)
@ -663,7 +663,7 @@ begin
Result := E_NOINTERFACE;
end;
function TComponent._AddRef: Integer;stdcall;
function TComponent._AddRef: Integer;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
if Assigned(VCLComObject) then
Result := IVCLComObject(VCLComObject)._AddRef
@ -671,7 +671,7 @@ begin
Result := -1;
end;
function TComponent._Release: Integer;stdcall;
function TComponent._Release: Integer;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
if Assigned(VCLComObject) then
Result := IVCLComObject(VCLComObject)._Release

6
rtl/objpas/classes/persist.inc
View File

@ -91,7 +91,7 @@ begin
end;
function TInterfacedPersistent._AddRef: Integer;stdcall;
function TInterfacedPersistent._AddRef: Integer;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
if assigned(FOwnerInterface) then
Result:=FOwnerInterface._AddRef
@ -100,7 +100,7 @@ begin
end;
function TInterfacedPersistent._Release: Integer;stdcall;
function TInterfacedPersistent._Release: Integer;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
if assigned(FOwnerInterface) then
Result:=FOwnerInterface._Release
@ -109,7 +109,7 @@ begin
end;
function TInterfacedPersistent.QueryInterface(const IID: TGUID; out Obj): HResult;stdcall;
function TInterfacedPersistent.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
if GetInterface(IID, Obj) then
Result:=0

8
tests/tbs/tb0546.pp
View File

@ -41,9 +41,9 @@ type
private
FInnerX: TInnerObject;
protected
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function QueryInterface(constref IID: TGUID; out Obj): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function GetX: TInnerObject; virtual;
function GetY: IYInterface;
public
@ -96,7 +96,7 @@ begin
result := -1;
end;
function TFoo.QueryInterface(const IID: TGUID; out Obj): HResult;
function TFoo.QueryInterface(constref IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;
end;function TFoo.GetX: TInnerObject;

53
tests/test/tconstref1.pp Normal file
View File

@ -0,0 +1,53 @@
program tConstRef1;
{$mode objfpc}{$h+}
uses
Classes, SysUtils;
type
TConstRefProc = procedure(constref AParam: integer);
TAClass = class(tobject)
private
function GetSomething(constref int:integer): integer;
public
property Something[constref int:integer] : integer read getSomething;
end;
function TAClass.GetSomething(constref int: integer): integer;
begin
if int<>$1234567 then
halt(1);
result := $54321;
end;
procedure TestConstRef(constref AParam: integer); [public, alias: '_TESTCONSTREF'];
begin
if AParam<>$1234567 then
halt(1);
end;
procedure TestConstRefAlias(AParam: PInteger); [external name '_TESTCONSTREF'];
const c = $1234567;
var a: integer;
aclass: TAClass;
p: TConstRefProc;
begin
a := $1234567;
TestConstRef(a);
TestConstRef(c);
TestConstRef($1234567);
TestConstRefAlias(@a);
aclass := TAClass.Create;
if aclass.Something[a]<>$54321 then
halt(1);
aclass.Free;
p := @TestConstRef;
p(c);
end.

12
tests/test/tconstref2.pp Normal file
View File

@ -0,0 +1,12 @@
{ %fail }
program tConstRef2;
procedure TestConstRef(constref AParam: integer);
begin
AParam := 5;
end;
begin
TestConstRef(1);
end.

82
tests/test/tconstref3.pp Normal file
View File

@ -0,0 +1,82 @@
program tconstref3;
{$mode objfpc}{$h+}
uses
SysUtils;
const
CGuid: TGuid = '{67BD8D43-8960-491C-AA3A-50EC74A02F36}';
type
PSmallRecord = ^TSmallRecord;
TSmallRecord = record
p: PtrInt;
end;
PAclass = ^TAclass;
TAclass = class
public
p: PtrInt;
end;
procedure TestConstRefIntegerAlias(AParam: PInteger); [external name '_TESTCONSTREFINTEGER'];
procedure TestConstRefInteger(constref AParam: integer); [public, alias: '_TESTCONSTREFINTEGER'];
begin
if AParam<>$1234567 then
halt(1);
end;
procedure TestConstRefStringAlias(AParam: PString); [external name '_TESTCONSTREFSTRING'];
procedure TestConstRefString(constref AParam: String); [public, alias: '_TESTCONSTREFSTRING'];
begin
if AParam<>'1234567' then
halt(1);
end;
procedure TestConstRefGUIDAlias(AParam: PGuid); [external name '_TESTCONSTREFGUID'];
procedure TestConstRefGUID(constref AParam: TGuid); [public, alias: '_TESTCONSTREFGUID'];
begin
if GUIDToString(AParam)<>'{67BD8D43-8960-491C-AA3A-50EC74A02F36}' then
halt(1);
end;
procedure TestConstRefRecordAlias(AParam: PSmallRecord); [external name '_TESTCONSTREFRECORD'];
procedure TestConstRefRecord(constref AParam: TSmallRecord); [public, alias: '_TESTCONSTREFRECORD'];
begin
if AParam.p<>$7654321 then
halt(1);
end;
procedure TestConstRefClassAlias(AParam: PAClass); [external name '_TESTCONSTREFCLASS'];
procedure TestConstRefClass(constref AParam: TAClass); [public, alias: '_TESTCONSTREFCLASS'];
begin
if AParam.p<>$3456789 then
halt(1);
end;
var a: integer;
s: string;
p: tguid;
sr: TSmallRecord;
ac: TAclass;
begin
a := $1234567;
TestConstRefIntegerAlias(@a);
s := '1234567';
TestConstRefStringAlias(@s);
p := CGuid;
TestConstRefGUIDAlias(@p);
sr.p:=$7654321;
TestConstRefRecordAlias(@sr);
ac := TAclass.Create;
ac.p := $3456789;
TestConstRefClassAlias(@ac);
ac.Free;
end.

41
tests/test/tconstref4.pp Normal file
View File

@ -0,0 +1,41 @@
program tconstref4;
{$mode objfpc}{$h+}
procedure TestConstRefSafecallAlias(AParam: PInteger); safecall; [external name '_TESTCONSTREFSAFECALL'];
procedure TestConstRefSafecall(constref AParam: integer); safecall; [public, alias: '_TESTCONSTREFSAFECALL'];
begin
if AParam<>$1234567 then
halt(1);
end;
procedure TestConstRefCdeclAlias(AParam: PInteger); cdecl; [external name '_TESTCONSTREFCDECL'];
procedure TestConstRefCdecl(constref AParam: integer); cdecl; [public, alias: '_TESTCONSTREFCDECL'];
begin
if AParam<>$1234567 then
halt(1);
end;
procedure TestConstRefStdcallAlias(AParam: PInteger); cdecl; [external name '_TESTCONSTREFSTDCALL'];
procedure TestConstRefStdcall(constref AParam: integer); cdecl; [public, alias: '_TESTCONSTREFSTDCALL'];
begin
if AParam<>$1234567 then
halt(1);
end;
procedure TestConstRefRegisterAlias(AParam: PInteger); cdecl; [external name '_TESTCONSTREFREGISTER'];
procedure TestConstRefRegister(constref AParam: integer); cdecl; [public, alias: '_TESTCONSTREFREGISTER'];
begin
if AParam<>$1234567 then
halt(1);
end;
var a : integer;
begin
a := $1234567;
TestConstRefSafecallAlias(@a);
TestConstRefStdcallAlias(@a);
TestConstRefRegisterAlias(@a);
TestConstRefCdeclAlias(@a);
end.

12
tests/test/tinterface4.pp
View File

@ -13,9 +13,9 @@ type
end;
TA = class(TObject, IA, IInterface)
destructor Destroy; override;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function QueryInterface(const iid: TGuid; out obj): HResult; stdcall;
function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function QueryInterface(constref iid: TGuid; out obj): HResult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
procedure AfterConstruction; override;
class function NewInstance: TObject; override;
end;
@ -32,13 +32,13 @@ begin
inherited AfterConstruction;
end;
function TA._AddRef: Integer; stdcall;
function TA._AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
InterlockedIncrement(fRefCount);
Result := 0;
end;
function TA._Release: Integer; stdcall;
function TA._Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
InterlockedDecrement(fRefCount);
if fRefCount = 0 then begin
@ -49,7 +49,7 @@ begin
Result := 0;
end;
function TA.QueryInterface(const iid: TGuid; out obj): HResult; stdcall;
function TA.QueryInterface(constref iid: TGuid; out obj): HResult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
Result := E_NOINTERFACE;
end;

8
tests/webtbs/tw10897.pp
View File

@ -22,9 +22,9 @@ type
fRef: Integer;
public
function GetOwner: IMyIntf;
function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function QueryInterface(constref IID: TGUID; out Obj): HRESULT; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
procedure Poing;
end;
@ -52,7 +52,7 @@ begin
Writeln('GetOwner2');
end;
function TMYClass.QueryInterface(const IID: TGUID; out Obj): HRESULT;
function TMYClass.QueryInterface(constref IID: TGUID; out Obj): HRESULT;
begin
if GetInterface(IID, Obj) then
result := S_OK else result := -1;

16
tests/webtbs/tw15363.pp
View File

@ -10,18 +10,18 @@ type
TTestBE = class (TObject, ITest)
function TestIt: integer;
{ IInterface }
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function QueryInterface(constref IID: TGUID; out Obj): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
End;
TTest = class (TPersistent, IInterface)
BE : TTestBE;
protected
{ IInterface }
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function QueryInterface(constref IID: TGUID; out Obj): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
End;
function TTestBE.TestIt : integer;
@ -39,7 +39,7 @@ begin
Result := -1;
end;
function TTest.QueryInterface(const IID: TGUID; out Obj): HResult;
function TTest.QueryInterface(constref IID: TGUID; out Obj): HResult;
begin
Result := BE.QueryInterface(IID, obj);
end;
@ -54,7 +54,7 @@ begin
Result := -1;
end;
function TTestBE.QueryInterface(const IID: TGUID; out Obj): HResult;
function TTestBE.QueryInterface(constref IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj)
then Result := 0

12
tests/webtbs/tw16592.pp
View File

@ -24,9 +24,9 @@ type
protected
FRefCount : longint;
public
function QueryInterface(const iid : tguid;out obj) : longint;stdcall;
function _AddRef : longint;stdcall;
function _Release : longint;stdcall;
function QueryInterface(constref iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
constructor Create;
@ -96,7 +96,7 @@ end;
WriteLn(Format('%s Obj=$%P class=%s RefCount=%d', [Str, Pointer(Self), ClassName, FRefCount]));
end;
function TInterfacedObj.QueryInterface(const iid: tguid; out obj): longint;stdcall;
function TInterfacedObj.QueryInterface(constref iid: tguid; out obj): longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
Result:=GetInterface(iid, obj);
@ -105,7 +105,7 @@ function TInterfacedObj.QueryInterface(const iid: tguid; out obj): longint;stdca
Result:=FOwner.QueryInterface(iid, obj);
end;
function TInterfacedObj._AddRef : longint;stdcall;[public,alias:'TInterfacedObj_AddRef'];
function TInterfacedObj._AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};[public,alias:'TInterfacedObj_AddRef'];
begin
if not FDestructorCalled then
begin
@ -117,7 +117,7 @@ function TInterfacedObj.QueryInterface(const iid: tguid; out obj): longint;stdca
end;
end;
function TInterfacedObj._Release : longint;stdcall;
function TInterfacedObj._Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
if FDestructorCalled then Exit;

12
tests/webtbs/tw2177.pp
View File

@ -16,25 +16,25 @@ type
Twii= class(TObject, ii)
s: string;
function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function QueryInterface(constref IID: TGUID; out Obj): Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
procedure Show;stdcall;
end;
{________doomy interfaces______}
function Twii.QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
function Twii.QueryInterface(constref IID: TGUID; out Obj): Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
result:= -1;
end;
function Twii._AddRef: Integer; stdcall;
function Twii._AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
result:= -1;
end;
function Twii._Release: Integer; stdcall;
function Twii._Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
result:= -1;
end;

12
tests/webtbs/tw4086.pp
View File

@ -19,9 +19,9 @@ type
ttestclass1 = class(tobject,itest)
public
function queryinterface(const guid: tguid; out obj): hresult; stdcall;
function _addref: integer; stdcall;
function _release: integer; stdcall;
function queryinterface(constref guid: tguid; out obj): hresult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _addref: integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _release: integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
procedure testproc;
end;
@ -32,19 +32,19 @@ type
{ ttestclass1 }
function ttestclass1.queryinterface(const guid: tguid; out obj): hresult; stdcall;
function ttestclass1.queryinterface(constref guid: tguid; out obj): hresult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
result:= integer(e_nointerface);
end;
function ttestclass1._addref: integer; stdcall;
function ttestclass1._addref: integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
writeln('addref called');
// result:= inherited _addref;
result:= -1;
end;
function ttestclass1._release: integer; stdcall;
function ttestclass1._release: integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
writeln('release called');
// result:= inherited _release;