paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-12 10:29:36 +02:00
Code Issues Packages Projects Releases Wiki Activity
c0d4efed2e
fpc/compiler/htypechk.pas

2653 lines
100 KiB
ObjectPascal
Raw Blame History

{
Copyright (c) 1998-2002 by Florian Klaempfl
This unit exports some help routines for the type checking
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit htypechk;
{$i fpcdefs.inc}
interface
uses
cclasses,tokens,cpuinfo,
node,globtype,
symconst,symtype,symdef,symsym,symbase;
type
Ttok2nodeRec=record
tok : ttoken;
nod : tnodetype;
op_overloading_supported : boolean;
end;
pcandidate = ^tcandidate;
tcandidate = record
next : pcandidate;
data : tprocdef;
wrongparaidx,
firstparaidx : integer;
exact_count,
equal_count,
cl1_count,
cl2_count,
cl3_count,
cl4_count,
cl5_count,
coper_count : integer; { should be signed }
ordinal_distance : double;
invalid : boolean;
wrongparanr : byte;
end;
tcallcandidates = class
private
FProcsym : tprocsym;
FProcsymtable : tsymtable;
FOperator : ttoken;
FCandidateProcs : pcandidate;
FProcCnt : integer;
FParaNode : tnode;
FParaLength : smallint;
FAllowVariant : boolean;
procedure collect_overloads_in_class(ProcdefOverloadList:TFPObjectList);
procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList);
procedure create_candidate_list(ignorevisibility,allowdefaultparas:boolean);
function proc_add(ps:tprocsym;pd:tprocdef):pcandidate;
public
constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas:boolean);
constructor create_operator(op:ttoken;ppn:tnode);
destructor destroy;override;
procedure list(all:boolean);
{$ifdef EXTDEBUG}
procedure dump_info(lvl:longint);
{$endif EXTDEBUG}
procedure get_information;
function choose_best(var bestpd:tabstractprocdef; singlevariant: boolean):integer;
procedure find_wrong_para;
property Count:integer read FProcCnt;
end;
type
tregableinfoflag = (
// can be put in a register if it's the address of a var/out/const parameter
ra_addr_regable,
// orthogonal to above flag: the address of the node is taken and may
// possibly escape the block in which this node is declared (e.g. a
// local variable is passed as var parameter to another procedure)
ra_addr_taken);
tregableinfoflags = set of tregableinfoflag;
const
tok2nodes=24;
tok2node:array[1..tok2nodes] of ttok2noderec=(
(tok:_PLUS ;nod:addn;op_overloading_supported:true), { binary overloading supported }
(tok:_MINUS ;nod:subn;op_overloading_supported:true), { binary and unary overloading supported }
(tok:_STAR ;nod:muln;op_overloading_supported:true), { binary overloading supported }
(tok:_SLASH ;nod:slashn;op_overloading_supported:true), { binary overloading supported }
(tok:_EQUAL ;nod:equaln;op_overloading_supported:true), { binary overloading supported }
(tok:_GT ;nod:gtn;op_overloading_supported:true), { binary overloading supported }
(tok:_LT ;nod:ltn;op_overloading_supported:true), { binary overloading supported }
(tok:_GTE ;nod:gten;op_overloading_supported:true), { binary overloading supported }
(tok:_LTE ;nod:lten;op_overloading_supported:true), { binary overloading supported }
(tok:_SYMDIF ;nod:symdifn;op_overloading_supported:true), { binary overloading supported }
(tok:_STARSTAR;nod:starstarn;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_AS ;nod:asn;op_overloading_supported:false), { binary overloading NOT supported }
(tok:_OP_IN ;nod:inn;op_overloading_supported:false), { binary overloading NOT supported }
(tok:_OP_IS ;nod:isn;op_overloading_supported:false), { binary overloading NOT supported }
(tok:_OP_OR ;nod:orn;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_AND ;nod:andn;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_DIV ;nod:divn;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_NOT ;nod:notn;op_overloading_supported:true), { unary overloading supported }
(tok:_OP_MOD ;nod:modn;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_SHL ;nod:shln;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_SHR ;nod:shrn;op_overloading_supported:true), { binary overloading supported }
(tok:_OP_XOR ;nod:xorn;op_overloading_supported:true), { binary overloading supported }
(tok:_ASSIGNMENT;nod:assignn;op_overloading_supported:true), { unary overloading supported }
(tok:_UNEQUAL ;nod:unequaln;op_overloading_supported:false) { binary overloading NOT supported overload = instead }
);
{ true, if we are parsing stuff which allows array constructors }
allow_array_constructor : boolean = false;
function node2opstr(nt:tnodetype):string;
{ check operator args and result type }
function isbinaryoperatoroverloadable(treetyp:tnodetype;ld:tdef;lt:tnodetype;rd:tdef;rt:tnodetype) : boolean;
function isoperatoracceptable(pf : tprocdef; optoken : ttoken) : boolean;
function isunaryoverloaded(var t : tnode) : boolean;
function isbinaryoverloaded(var t : tnode) : boolean;
{ Register Allocation }
procedure make_not_regable(p : tnode; how: tregableinfoflags);
{ procvar handling }
function is_procvar_load(p:tnode):boolean;
procedure test_local_to_procvar(from_def:tprocvardef;to_def:tdef);
{ sets varsym varstate field correctly }
type
tvarstateflag = (vsf_must_be_valid,vsf_use_hints);
tvarstateflags = set of tvarstateflag;
procedure set_varstate(p:tnode;newstate:tvarstate;varstateflags:tvarstateflags);
{ sets the callunique flag, if the node is a vecn, }
{ takes care of type casts etc. }
procedure set_unique(p : tnode);
function valid_for_formal_var(p : tnode; report_errors: boolean) : boolean;
function valid_for_formal_const(p : tnode; report_errors: boolean) : boolean;
function valid_for_var(p:tnode; report_errors: boolean):boolean;
function valid_for_assignment(p:tnode; report_errors: boolean):boolean;
function valid_for_loopvar(p:tnode; report_errors: boolean):boolean;
function valid_for_addr(p : tnode; report_errors: boolean) : boolean;
function allowenumop(nt:tnodetype):boolean;
procedure check_hints(const srsym: tsym; const symoptions: tsymoptions);
procedure check_ranges(const location: tfileposinfo; source: tnode; destdef: tdef);
implementation
uses
sysutils,
systems,constexp,globals,
cutils,verbose,
symtable,
defutil,defcmp,
nbas,ncnv,nld,nmem,ncal,nmat,ninl,nutils,ncon,
cgbase,procinfo
;
type
TValidAssign=(Valid_Property,Valid_Void,Valid_Const,Valid_Addr,Valid_Packed);
TValidAssigns=set of TValidAssign;
function node2opstr(nt:tnodetype):string;
var
i : integer;
begin
result:='<unknown>';
for i:=1 to tok2nodes do
if tok2node[i].nod=nt then
begin
result:=tokeninfo^[tok2node[i].tok].str;
break;
end;
end;
function isbinaryoperatoroverloadable(treetyp:tnodetype;ld:tdef;lt:tnodetype;rd:tdef;rt:tnodetype) : boolean;
function internal_check(treetyp:tnodetype;ld:tdef;lt:tnodetype;rd:tdef;rt:tnodetype;var allowed:boolean):boolean;
begin
internal_check:=true;
case ld.typ of
formaldef,
recorddef,
variantdef :
begin
allowed:=true;
end;
procvardef :
begin
if (rd.typ in [pointerdef,procdef,procvardef]) then
begin
allowed:=false;
exit;
end;
allowed:=true;
end;
pointerdef :
begin
if ((rd.typ in [orddef,enumdef,pointerdef,classrefdef,procvardef]) or
is_class_or_interface(rd)) then
begin
allowed:=false;
exit;
end;
{ don't allow pchar+string }
if (is_pchar(ld) or is_pwidechar(ld)) and
((rd.typ=stringdef) or
is_pchar(rd) or
is_pwidechar(rd) or
is_chararray(rd) or
is_widechararray(rd)) then
begin
allowed:=false;
exit;
end;
allowed:=true;
end;
arraydef :
begin
{ not vector/mmx }
if ((cs_mmx in current_settings.localswitches) and
is_mmx_able_array(ld)) or
((cs_support_vectors in current_settings.globalswitches) and
is_vector(ld)) then
begin
allowed:=false;
exit;
end;
{ not chararray+[(wide)char,(wide)string,(wide)chararray] }
if (is_chararray(ld) or is_widechararray(ld) or
is_open_chararray(ld) or is_open_widechararray(ld))
and
((rd.typ in [stringdef,orddef,enumdef]) or
is_pchar(rd) or
is_pwidechar(rd) or
is_chararray(rd) or
is_widechararray(rd) or
is_open_chararray(rd) or
is_open_widechararray(rd) or
(rt=niln)) then
begin
allowed:=false;
exit;
end;
{ dynamic array compare with niln }
if ((is_dynamic_array(ld) and
(rt=niln)) or
(is_dynamic_array(ld) and is_dynamic_array(rd)))
and
(treetyp in [equaln,unequaln]) then
begin
allowed:=false;
exit;
end;
allowed:=true;
end;
objectdef :
begin
{ <> and = are defined for classes }
if (treetyp in [equaln,unequaln]) and
is_class_or_interface(ld) then
begin
allowed:=false;
exit;
end;
allowed:=true;
end;
stringdef :
begin
if (rd.typ in [orddef,enumdef,stringdef]) or
is_pchar(rd) or
is_pwidechar(rd) or
is_chararray(rd) or
is_widechararray(rd) or
is_open_chararray(rd) or
is_open_widechararray(rd) then
begin
allowed:=false;
exit;
end;
allowed:=true;
end;
else
internal_check:=false;
end;
end;
var
allowed : boolean;
begin
{ power ** is always possible }
if (treetyp=starstarn) then
begin
isbinaryoperatoroverloadable:=true;
exit;
end;
{ order of arguments does not matter so we have to check also
the reversed order }
allowed:=false;
if not internal_check(treetyp,ld,lt,rd,rt,allowed) then
internal_check(treetyp,rd,rt,ld,lt,allowed);
isbinaryoperatoroverloadable:=allowed;
end;
function isunaryoperatoroverloadable(treetyp : tnodetype;ld : tdef) : boolean;
begin
result:=false;
case treetyp of
subn,
unaryminusn :
begin
if (ld.typ in [orddef,enumdef,floatdef]) then
exit;
{$ifdef SUPPORT_MMX}
if (cs_mmx in current_settings.localswitches) and
is_mmx_able_array(ld) then
exit;
{$endif SUPPORT_MMX}
result:=true;
end;
notn :
begin
if (ld.typ in [orddef,enumdef,floatdef]) then
exit;
{$ifdef SUPPORT_MMX}
if (cs_mmx in current_settings.localswitches) and
is_mmx_able_array(ld) then
exit;
{$endif SUPPORT_MMX}
result:=true;
end;
end;
end;
function isoperatoracceptable(pf : tprocdef; optoken : ttoken) : boolean;
var
ld,rd : tdef;
i : longint;
eq : tequaltype;
conv : tconverttype;
pd : tprocdef;
oldcount,
count: longint;
parasym : tparavarsym;
begin
result:=false;
count := pf.parast.SymList.count;
oldcount:=count;
while count > 0 do
begin
parasym:=tparavarsym(pf.parast.SymList[count-1]);
if is_boolean(parasym.vardef) then
begin
if parasym.name='RANGECHECK' then
begin
Include(parasym.varoptions, vo_is_hidden_para);
Include(parasym.varoptions, vo_is_range_check);
Dec(count);
end
else if parasym.name='OVERFLOWCHECK' then
begin
Include(parasym.varoptions, vo_is_hidden_para);
Include(parasym.varoptions, vo_is_overflow_check);
Dec(count);
end
else
break;
end
else
break;
end;
if count<>oldcount then
pf.calcparas;
case count of
1 : begin
ld:=tparavarsym(pf.parast.SymList[0]).vardef;
{ assignment is a special case }
if optoken=_ASSIGNMENT then
begin
eq:=compare_defs_ext(ld,pf.returndef,nothingn,conv,pd,[cdo_explicit]);
result:=
(eq=te_incompatible) and
{ don't allow overloading assigning to custom shortstring
types, because we also don't want to differentiate based
on different shortstring types (e.g.,
"operator :=(const v: variant) res: shorstring" also
has to work for assigning a variant to a string[80])
}
(not is_shortstring(pf.returndef) or
(tstringdef(pf.returndef).len=255));
end
else
begin
for i:=1 to tok2nodes do
if tok2node[i].tok=optoken then
begin
result:=
tok2node[i].op_overloading_supported and
isunaryoperatoroverloadable(tok2node[i].nod,ld);
break;
end;
end;
end;
2 : begin
for i:=1 to tok2nodes do
if tok2node[i].tok=optoken then
begin
ld:=tparavarsym(pf.parast.SymList[0]).vardef;
rd:=tparavarsym(pf.parast.SymList[1]).vardef;
result:=
tok2node[i].op_overloading_supported and
isbinaryoperatoroverloadable(tok2node[i].nod,ld,nothingn,rd,nothingn);
break;
end;
end;
end;
end;
function isunaryoverloaded(var t : tnode) : boolean;
var
ld : tdef;
optoken : ttoken;
operpd : tprocdef;
ppn : tcallparanode;
candidates : tcallcandidates;
cand_cnt : integer;
begin
result:=false;
operpd:=nil;
{ load easier access variables }
ld:=tunarynode(t).left.resultdef;
if not isunaryoperatoroverloadable(t.nodetype,ld) then
exit;
{ operator overload is possible }
result:=true;
case t.nodetype of
notn:
optoken:=_OP_NOT;
unaryminusn:
optoken:=_MINUS;
else
begin
CGMessage(parser_e_operator_not_overloaded);
t:=cnothingnode.create;
exit;
end;
end;
{ generate parameter nodes }
ppn:=ccallparanode.create(tunarynode(t).left.getcopy,nil);
ppn.get_paratype;
candidates:=tcallcandidates.create_operator(optoken,ppn);
{ stop when there are no operators found }
if candidates.count=0 then
begin
CGMessage(parser_e_operator_not_overloaded);
candidates.free;
ppn.free;
t:=cnothingnode.create;
exit;
end;
{ Retrieve information about the candidates }
candidates.get_information;
{$ifdef EXTDEBUG}
{ Display info when multiple candidates are found }
candidates.dump_info(V_Debug);
{$endif EXTDEBUG}
cand_cnt:=candidates.choose_best(tabstractprocdef(operpd),false);
{ exit when no overloads are found }
if cand_cnt=0 then
begin
CGMessage(parser_e_operator_not_overloaded);
candidates.free;
ppn.free;
t:=cnothingnode.create;
exit;
end;
{ Multiple candidates left? }
if cand_cnt>1 then
begin
CGMessage(type_e_cant_choose_overload_function);
{$ifdef EXTDEBUG}
candidates.dump_info(V_Hint);
{$else EXTDEBUG}
candidates.list(false);
{$endif EXTDEBUG}
{ we'll just use the first candidate to make the
call }
end;
candidates.free;
addsymref(operpd.procsym);
{ the nil as symtable signs firstcalln that this is
an overloaded operator }
t:=ccallnode.create(ppn,Tprocsym(operpd.procsym),nil,nil,[]);
{ we already know the procdef to use, so it can
skip the overload choosing in callnode.pass_typecheck }
tcallnode(t).procdefinition:=operpd;
end;
function isbinaryoverloaded(var t : tnode) : boolean;
var
rd,ld : tdef;
optoken : ttoken;
operpd : tprocdef;
ht : tnode;
ppn : tcallparanode;
candidates : tcallcandidates;
cand_cnt : integer;
begin
isbinaryoverloaded:=false;
operpd:=nil;
{ load easier access variables }
ld:=tbinarynode(t).left.resultdef;
rd:=tbinarynode(t).right.resultdef;
if not isbinaryoperatoroverloadable(t.nodetype,ld,tbinarynode(t).left.nodetype,rd,tbinarynode(t).right.nodetype) then
exit;
{ operator overload is possible }
result:=true;
case t.nodetype of
equaln,
unequaln :
optoken:=_EQUAL;
addn:
optoken:=_PLUS;
subn:
optoken:=_MINUS;
muln:
optoken:=_STAR;
starstarn:
optoken:=_STARSTAR;
slashn:
optoken:=_SLASH;
ltn:
optoken:=_LT;
gtn:
optoken:=_GT;
lten:
optoken:=_LTE;
gten:
optoken:=_GTE;
symdifn :
optoken:=_SYMDIF;
modn :
optoken:=_OP_MOD;
orn :
optoken:=_OP_OR;
xorn :
optoken:=_OP_XOR;
andn :
optoken:=_OP_AND;
divn :
optoken:=_OP_DIV;
shln :
optoken:=_OP_SHL;
shrn :
optoken:=_OP_SHR;
else
begin
CGMessage(parser_e_operator_not_overloaded);
t:=cnothingnode.create;
exit;
end;
end;
{ generate parameter nodes }
ppn:=ccallparanode.create(tbinarynode(t).right.getcopy,ccallparanode.create(tbinarynode(t).left.getcopy,nil));
ppn.get_paratype;
candidates:=tcallcandidates.create_operator(optoken,ppn);
{ for commutative operators we can swap arguments and try again }
if (candidates.count=0) and
not(optoken in [_OP_SHL,_OP_SHR,_OP_DIV,_OP_MOD,_STARSTAR,_SLASH,_MINUS]) then
begin
candidates.free;
reverseparameters(ppn);
{ reverse compare operators }
case optoken of
_LT:
optoken:=_GTE;
_GT:
optoken:=_LTE;
_LTE:
optoken:=_GT;
_GTE:
optoken:=_LT;
end;
candidates:=tcallcandidates.create_operator(optoken,ppn);
end;
{ stop when there are no operators found }
if candidates.count=0 then
begin
CGMessage(parser_e_operator_not_overloaded);
candidates.free;
ppn.free;
t:=cnothingnode.create;
exit;
end;
{ Retrieve information about the candidates }
candidates.get_information;
{$ifdef EXTDEBUG}
{ Display info when multiple candidates are found }
candidates.dump_info(V_Debug);
{$endif EXTDEBUG}
cand_cnt:=candidates.choose_best(tabstractprocdef(operpd),false);
{ exit when no overloads are found }
if cand_cnt=0 then
begin
CGMessage(parser_e_operator_not_overloaded);
candidates.free;
ppn.free;
t:=cnothingnode.create;
exit;
end;
{ Multiple candidates left? }
if cand_cnt>1 then
begin
CGMessage(type_e_cant_choose_overload_function);
{$ifdef EXTDEBUG}
candidates.dump_info(V_Hint);
{$else EXTDEBUG}
candidates.list(false);
{$endif EXTDEBUG}
{ we'll just use the first candidate to make the
call }
end;
candidates.free;
addsymref(operpd.procsym);
{ the nil as symtable signs firstcalln that this is
an overloaded operator }
ht:=ccallnode.create(ppn,Tprocsym(operpd.procsym),nil,nil,[]);
{ we already know the procdef to use, so it can
skip the overload choosing in callnode.pass_typecheck }
tcallnode(ht).procdefinition:=operpd;
if t.nodetype=unequaln then
ht:=cnotnode.create(ht);
t:=ht;
end;
{****************************************************************************
Register Calculation
****************************************************************************}
{ marks an lvalue as "unregable" }
procedure make_not_regable_intern(p : tnode; how: tregableinfoflags; records_only: boolean);
var
update_regable: boolean;
begin
update_regable:=true;
repeat
case p.nodetype of
subscriptn:
begin
records_only:=true;
p:=tsubscriptnode(p).left;
end;
vecn:
begin
{ arrays are currently never regable and pointers indexed like }
{ arrays do not have be made unregable, but we do need to }
{ propagate the ra_addr_taken info }
update_regable:=false;
p:=tvecnode(p).left;
end;
typeconvn :
begin
if (ttypeconvnode(p).resultdef.typ = recorddef) then
records_only:=false;
p:=ttypeconvnode(p).left;
end;
loadn :
begin
if (tloadnode(p).symtableentry.typ in [staticvarsym,localvarsym,paravarsym]) then
begin
if (ra_addr_taken in how) then
tabstractvarsym(tloadnode(p).symtableentry).addr_taken:=true;
if update_regable and
(tabstractvarsym(tloadnode(p).symtableentry).varregable <> vr_none) and
((not records_only) or
(tabstractvarsym(tloadnode(p).symtableentry).vardef.typ = recorddef)) then
if (tloadnode(p).symtableentry.typ = paravarsym) and
(ra_addr_regable in how) then
tabstractvarsym(tloadnode(p).symtableentry).varregable:=vr_addr
else
tabstractvarsym(tloadnode(p).symtableentry).varregable:=vr_none;
end;
break;
end;
temprefn :
begin
if (ra_addr_taken in how) then
include(ttemprefnode(p).tempinfo^.flags,ti_addr_taken);
if update_regable and
(ti_may_be_in_reg in ttemprefnode(p).tempinfo^.flags) and
((not records_only) or
(ttemprefnode(p).tempinfo^.typedef.typ = recorddef)) then
exclude(ttemprefnode(p).tempinfo^.flags,ti_may_be_in_reg);
break;
end;
else
break;
end;
until false;
end;
procedure make_not_regable(p : tnode; how: tregableinfoflags);
begin
make_not_regable_intern(p,how,false);
end;
{****************************************************************************
Subroutine Handling
****************************************************************************}
function is_procvar_load(p:tnode):boolean;
begin
result:=false;
{ remove voidpointer typecast for tp procvars }
if ((m_tp_procvar in current_settings.modeswitches) or
(m_mac_procvar in current_settings.modeswitches)) and
(p.nodetype=typeconvn) and
is_voidpointer(p.resultdef) then
p:=tunarynode(p).left;
result:=(p.nodetype=typeconvn) and
(ttypeconvnode(p).convtype=tc_proc_2_procvar);
end;
{ local routines can't be assigned to procvars }
procedure test_local_to_procvar(from_def:tprocvardef;to_def:tdef);
begin
if (from_def.parast.symtablelevel>normal_function_level) and
(to_def.typ=procvardef) then
CGMessage(type_e_cannot_local_proc_to_procvar);
end;
procedure set_varstate(p:tnode;newstate:tvarstate;varstateflags:tvarstateflags);
const
vstrans: array[tvarstate,tvarstate] of tvarstate = (
{ vs_none -> ... }
(vs_none,vs_declared,vs_initialised,vs_read,vs_read_not_warned,vs_referred_not_inited,vs_written,vs_readwritten),
{ vs_declared -> ... }
(vs_none,vs_declared,vs_initialised,vs_read,vs_read_not_warned,vs_referred_not_inited,vs_written,vs_readwritten),
{ vs_initialised -> ... }
(vs_none,vs_initialised,vs_initialised,vs_read,vs_read,vs_read,vs_written,vs_readwritten),
{ vs_read -> ... }
(vs_none,vs_read,vs_read,vs_read,vs_read,vs_read,vs_readwritten,vs_readwritten),
{ vs_read_not_warned -> ... }
(vs_none,vs_read_not_warned,vs_read,vs_read,vs_read_not_warned,vs_read_not_warned,vs_readwritten,vs_readwritten),
{ vs_referred_not_inited }
(vs_none,vs_referred_not_inited,vs_read,vs_read,vs_read_not_warned,vs_referred_not_inited,vs_written,vs_readwritten),
{ vs_written -> ... }
(vs_none,vs_written,vs_written,vs_readwritten,vs_readwritten,vs_written,vs_written,vs_readwritten),
{ vs_readwritten -> ... }
(vs_none,vs_readwritten,vs_readwritten,vs_readwritten,vs_readwritten,vs_readwritten,vs_readwritten,vs_readwritten));
var
hsym : tabstractvarsym;
begin
{ make sure we can still warn about uninitialised use after high(v), @v etc }
if (newstate = vs_read) and
not(vsf_must_be_valid in varstateflags) then
newstate := vs_referred_not_inited;
while assigned(p) do
begin
case p.nodetype of
derefn:
begin
if (tderefnode(p).left.nodetype=temprefn) and
assigned(ttemprefnode(tderefnode(p).left).tempinfo^.withnode) then
p:=ttemprefnode(tderefnode(p).left).tempinfo^.withnode
else
break;
end;
typeconvn :
begin
case ttypeconvnode(p).convtype of
tc_cchar_2_pchar,
tc_cstring_2_pchar,
tc_array_2_pointer :
exclude(varstateflags,vsf_must_be_valid);
tc_pchar_2_string,
tc_pointer_2_array :
include(varstateflags,vsf_must_be_valid);
end;
p:=tunarynode(p).left;
end;
subscriptn :
begin
if is_class_or_interface(tunarynode(p).left.resultdef) then
newstate := vs_read;
p:=tunarynode(p).left;
end;
vecn:
begin
set_varstate(tbinarynode(p).right,vs_read,[vsf_must_be_valid]);
if (newstate in [vs_read,vs_readwritten]) or
not(tunarynode(p).left.resultdef.typ in [stringdef,arraydef]) then
include(varstateflags,vsf_must_be_valid)
else if (newstate = vs_written) then
exclude(varstateflags,vsf_must_be_valid);
p:=tunarynode(p).left;
end;
{ do not parse calln }
calln :
break;
loadn :
begin
if (tloadnode(p).symtableentry.typ in [localvarsym,paravarsym,staticvarsym]) then
begin
hsym:=tabstractvarsym(tloadnode(p).symtableentry);
if (vsf_must_be_valid in varstateflags) and
(hsym.varstate in [vs_declared,vs_read_not_warned,vs_referred_not_inited]) then
begin
{ Give warning/note for uninitialized locals }
if assigned(hsym.owner) and
not(cs_opt_nodedfa in current_settings.optimizerswitches) and
not(vo_is_external in hsym.varoptions) and
(hsym.owner.symtabletype in [parasymtable,localsymtable,staticsymtable]) and
((hsym.owner=current_procinfo.procdef.localst) or
(hsym.owner=current_procinfo.procdef.parast)) then
begin
if (vo_is_funcret in hsym.varoptions) then
begin
if (vsf_use_hints in varstateflags) then
CGMessagePos(p.fileinfo,sym_h_function_result_uninitialized)
else
CGMessagePos(p.fileinfo,sym_w_function_result_uninitialized)
end
else
begin
if tloadnode(p).symtable.symtabletype=localsymtable then
begin
if (vsf_use_hints in varstateflags) then
CGMessagePos1(p.fileinfo,sym_h_uninitialized_local_variable,hsym.realname)
else
CGMessagePos1(p.fileinfo,sym_w_uninitialized_local_variable,hsym.realname);
end
else
begin
if (vsf_use_hints in varstateflags) then
CGMessagePos1(p.fileinfo,sym_h_uninitialized_variable,hsym.realname)
else
CGMessagePos1(p.fileinfo,sym_w_uninitialized_variable,hsym.realname);
end;
end;
end
else if (newstate = vs_read) then
newstate := vs_read_not_warned;
end;
hsym.varstate := vstrans[hsym.varstate,newstate];
end;
case newstate of
vs_written:
include(tloadnode(p).flags,nf_write);
vs_readwritten:
if not(nf_write in tloadnode(p).flags) then
include(tloadnode(p).flags,nf_modify);
end;
break;
end;
callparan :
internalerror(200310081);
else
break;
end;{case }
end;
end;
procedure set_unique(p : tnode);
begin
while assigned(p) do
begin
case p.nodetype of
vecn:
begin
include(p.flags,nf_callunique);
break;
end;
typeconvn,
subscriptn,
derefn:
p:=tunarynode(p).left;
else
break;
end;
end;
end;
function valid_for_assign(p:tnode;opts:TValidAssigns; report_errors: boolean):boolean;
var
hp2,
hp : tnode;
gotstring,
gotsubscript,
gotrecord,
gotpointer,
gotvec,
gotclass,
gotdynarray,
gotderef,
gottypeconv : boolean;
fromdef,
todef : tdef;
errmsg,
temp : longint;
begin
if valid_const in opts then
errmsg:=type_e_variable_id_expected
else if valid_property in opts then
errmsg:=type_e_argument_cant_be_assigned
else
errmsg:=type_e_no_addr_of_constant;
result:=false;
gotsubscript:=false;
gotvec:=false;
gotderef:=false;
gotrecord:=false;
gotclass:=false;
gotpointer:=false;
gotdynarray:=false;
gotstring:=false;
gottypeconv:=false;
hp:=p;
if not(valid_void in opts) and
is_void(hp.resultdef) then
begin
if report_errors then
CGMessagePos(hp.fileinfo,errmsg);
exit;
end;
while assigned(hp) do
begin
{ property allowed? calln has a property check itself }
if (nf_isproperty in hp.flags) then
begin
{ check return type }
case hp.resultdef.typ of
pointerdef :
gotpointer:=true;
objectdef :
gotclass:=is_class_or_interface(hp.resultdef);
recorddef :
gotrecord:=true;
classrefdef :
gotclass:=true;
stringdef :
gotstring:=true;
end;
if (valid_property in opts) then
begin
{ don't allow writing to calls that will create
temps like calls that return a structure and we
are assigning to a member }
if (valid_const in opts) or
{ if we got a deref, we won't modify the property itself }
(gotderef) or
{ same when we got a class and subscript (= deref) }
(gotclass and gotsubscript) or
(
{ allowing assignments to typecasted properties
a) is Delphi-incompatible
b) causes problems in case the getter is a function
(because then the result of the getter is
typecasted to this type, and then we "assign" to
this typecasted function result) -> always
disallow, since property accessors should be
transparantly changeable to functions at all
times
}
not(gottypeconv) and
not(gotsubscript and gotrecord) and
not(gotstring and gotvec)
) then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,errmsg);
end
else
begin
{ 1. if it returns a pointer and we've found a deref,
2. if it returns a class or record and a subscription or with is found
3. if the address is needed of a field (subscriptn, vecn) }
if (gotpointer and gotderef) or
(gotstring and gotvec) or
(
(gotclass or gotrecord) and
(gotsubscript)
) or
(
(gotvec and gotdynarray)
) or
(
(Valid_Addr in opts) and
(hp.nodetype in [subscriptn,vecn])
) then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,errmsg);
end;
exit;
end;
case hp.nodetype of
temprefn :
begin
valid_for_assign := true;
exit;
end;
derefn :
begin
gotderef:=true;
hp:=tderefnode(hp).left;
end;
typeconvn :
begin
gottypeconv:=true;
{ typecast sizes must match, exceptions:
- implicit typecast made by absolute
- from formaldef
- from void
- from/to open array
- typecast from pointer to array }
fromdef:=ttypeconvnode(hp).left.resultdef;
todef:=hp.resultdef;
if not((nf_absolute in ttypeconvnode(hp).flags) or
(fromdef.typ=formaldef) or
is_void(fromdef) or
is_open_array(fromdef) or
is_open_array(todef) or
((fromdef.typ=pointerdef) and (todef.typ=arraydef)) or
((fromdef.typ = objectdef) and (todef.typ = objectdef) and
(tobjectdef(fromdef).is_related(tobjectdef(todef))))) and
(fromdef.size<>todef.size) then
begin
{ in TP it is allowed to typecast to smaller types. But the variable can't
be in a register }
if (m_tp7 in current_settings.modeswitches) or
(todef.size<fromdef.size) then
make_not_regable(hp,[ra_addr_regable])
else
if report_errors then
CGMessagePos2(hp.fileinfo,type_e_typecast_wrong_size_for_assignment,tostr(fromdef.size),tostr(todef.size));
end;
{ don't allow assignments to typeconvs that need special code }
if not(gotsubscript or gotvec or gotderef) and
not(ttypeconvnode(hp).assign_allowed) then
begin
if report_errors then
CGMessagePos(hp.fileinfo,errmsg);
exit;
end;
case hp.resultdef.typ of
pointerdef :
gotpointer:=true;
objectdef :
gotclass:=is_class_or_interface(hp.resultdef);
classrefdef :
gotclass:=true;
arraydef :
begin
{ pointer -> array conversion is done then we need to see it
as a deref, because a ^ is then not required anymore }
if (ttypeconvnode(hp).left.resultdef.typ=pointerdef) then
gotderef:=true;
end;
end;
hp:=ttypeconvnode(hp).left;
end;
vecn :
begin
if { only check for first (= outermost) vec node }
not gotvec and
not(valid_packed in opts) and
(tvecnode(hp).left.resultdef.typ = arraydef) and
(ado_IsBitPacked in tarraydef(tvecnode(hp).left.resultdef).arrayoptions) and
((tarraydef(tvecnode(hp).left.resultdef).elepackedbitsize mod 8 <> 0) or
(is_ordinal(tarraydef(tvecnode(hp).left.resultdef).elementdef) and
not ispowerof2(tarraydef(tvecnode(hp).left.resultdef).elepackedbitsize div 8,temp))) then
begin
if report_errors then
if (valid_property in opts) then
CGMessagePos(hp.fileinfo,parser_e_packed_element_no_loop)
else
CGMessagePos(hp.fileinfo,parser_e_packed_element_no_var_addr);
exit;
end;
gotvec:=true;
{ accesses to dyn. arrays override read only access in delphi }
if (m_delphi in current_settings.modeswitches) and is_dynamic_array(tunarynode(hp).left.resultdef) then
gotdynarray:=true;
hp:=tunarynode(hp).left;
end;
blockn :
begin
hp2:=tblocknode(hp).statements;
if assigned(hp2) then
begin
if hp2.nodetype<>statementn then
internalerror(2006110801);
while assigned(tstatementnode(hp2).next) do
hp2:=tstatementnode(hp2).next;
hp:=tstatementnode(hp2).statement;
end
else
begin
if report_errors then
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
end;
asn :
begin
{ asn can't be assigned directly, it returns the value in a register instead
of reference. }
if not(gotsubscript or gotderef or gotvec) then
begin
if report_errors then
CGMessagePos(hp.fileinfo,errmsg);
exit;
end;
hp:=tunarynode(hp).left;
end;
subscriptn :
begin
{ only check first (= outermost) subscriptn }
if not gotsubscript and
not(valid_packed in opts) and
is_packed_record_or_object(tsubscriptnode(hp).left.resultdef) and
((tsubscriptnode(hp).vs.fieldoffset mod 8 <> 0) or
(is_ordinal(tsubscriptnode(hp).resultdef) and
not ispowerof2(tsubscriptnode(hp).resultdef.packedbitsize div 8,temp))) then
begin
if report_errors then
if (valid_property in opts) then
CGMessagePos(hp.fileinfo,parser_e_packed_element_no_loop)
else
CGMessagePos(hp.fileinfo,parser_e_packed_element_no_var_addr);
exit;
end;
gotsubscript:=true;
{ loop counter? }
if not(Valid_Const in opts) and
(vo_is_loop_counter in tsubscriptnode(hp).vs.varoptions) then
begin
if report_errors then
CGMessage1(parser_e_illegal_assignment_to_count_var,tsubscriptnode(hp).vs.realname)
else
exit;
end;
{ a class/interface access is an implicit }
{ dereferencing }
hp:=tsubscriptnode(hp).left;
if is_class_or_interface(hp.resultdef) then
gotderef:=true;
end;
muln,
divn,
andn,
xorn,
orn,
notn,
subn,
addn :
begin
{ Allow operators on a pointer, or an integer
and a pointer typecast and deref has been found }
if ((hp.resultdef.typ=pointerdef) or
(is_integer(hp.resultdef) and gotpointer)) and
gotderef then
result:=true
else
{ Temp strings are stored in memory, for compatibility with
delphi only }
if (m_delphi in current_settings.modeswitches) and
((valid_addr in opts) or
(valid_const in opts)) and
(hp.resultdef.typ=stringdef) then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
niln,
pointerconstn :
begin
{ to support e.g. @tmypointer(0)^.data; see tests/tbs/tb0481 }
if gotderef then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr);
exit;
end;
ordconstn,
realconstn :
begin
{ these constants will be passed by value }
if report_errors then
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
setconstn,
stringconstn,
guidconstn :
begin
{ these constants will be passed by reference }
if valid_const in opts then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
addrn :
begin
if gotderef then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr);
exit;
end;
calln :
begin
{ check return type }
case hp.resultdef.typ of
arraydef :
begin
{ dynamic arrays are allowed when there is also a
vec node }
if is_dynamic_array(hp.resultdef) and
gotvec then
begin
gotderef:=true;
gotpointer:=true;
end;
end;
pointerdef :
gotpointer:=true;
objectdef :
gotclass:=is_class_or_interface(hp.resultdef);
recorddef, { handle record like class it needs a subscription }
classrefdef :
gotclass:=true;
stringdef :
gotstring:=true;
end;
{ 1. if it returns a pointer and we've found a deref,
2. if it returns a class or record and a subscription or with is found
3. string is returned }
if (gotstring and gotvec) or
(gotpointer and gotderef) or
(gotclass and gotsubscript) then
result:=true
else
{ Temp strings are stored in memory, for compatibility with
delphi only }
if (m_delphi in current_settings.modeswitches) and
(valid_addr in opts) and
(hp.resultdef.typ=stringdef) then
result:=true
else
if ([valid_const,valid_addr] * opts = [valid_const]) then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,errmsg);
exit;
end;
inlinen :
begin
if ((valid_const in opts) and
(tinlinenode(hp).inlinenumber in [in_typeof_x]))
{$ifdef SUPPORT_UNALIGNED}
or (tinlinenode(hp).inlinenumber in [in_unaligned_x])
{$endif SUPPORT_UNALIGNED}
then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
dataconstn:
begin
{ only created internally, so no additional checks necessary }
result:=true;
exit;
end;
loadn :
begin
case tloadnode(hp).symtableentry.typ of
absolutevarsym,
staticvarsym,
localvarsym,
paravarsym :
begin
{ loop counter? }
if not(Valid_Const in opts) and
not gotderef and
(vo_is_loop_counter in tabstractvarsym(tloadnode(hp).symtableentry).varoptions) then
if report_errors then
CGMessage1(parser_e_illegal_assignment_to_count_var,tloadnode(hp).symtableentry.realname)
else
exit;
{ read-only variable? }
if (tabstractvarsym(tloadnode(hp).symtableentry).varspez=vs_const) then
begin
{ allow p^:= constructions with p is const parameter }
if gotderef or gotdynarray or (Valid_Const in opts) or
(nf_isinternal_ignoreconst in tloadnode(hp).flags) then
result:=true
else
if report_errors then
CGMessagePos(tloadnode(hp).fileinfo,type_e_no_assign_to_const);
exit;
end;
result:=true;
exit;
end;
procsym :
begin
if (Valid_Const in opts) then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
labelsym :
begin
if (Valid_Addr in opts) then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
constsym:
begin
if (tconstsym(tloadnode(hp).symtableentry).consttyp=constresourcestring) and
(valid_addr in opts) then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
else
begin
if report_errors then
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
end;
end;
else
begin
if report_errors then
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
end;
end;
end;
function valid_for_var(p:tnode; report_errors: boolean):boolean;
begin
valid_for_var:=valid_for_assign(p,[],report_errors);
end;
function valid_for_formal_var(p : tnode; report_errors: boolean) : boolean;
begin
valid_for_formal_var:=valid_for_assign(p,[valid_void],report_errors);
end;
function valid_for_formal_const(p : tnode; report_errors: boolean) : boolean;
begin
valid_for_formal_const:=(p.resultdef.typ=formaldef) or
valid_for_assign(p,[valid_void,valid_const,valid_property],report_errors);
end;
function valid_for_assignment(p:tnode; report_errors: boolean):boolean;
begin
valid_for_assignment:=valid_for_assign(p,[valid_property,valid_packed],report_errors);
end;
function valid_for_loopvar(p:tnode; report_errors: boolean):boolean;
begin
valid_for_loopvar:=valid_for_assign(p,[valid_property],report_errors);
end;
function valid_for_addr(p : tnode; report_errors: boolean) : boolean;
begin
result:=valid_for_assign(p,[valid_const,valid_addr,valid_void],report_errors);
end;
procedure var_para_allowed(var eq:tequaltype;def_from,def_to:Tdef; fromnode: tnode);
begin
{ Note: eq must be already valid, it will only be updated! }
case def_to.typ of
formaldef :
begin
{ all types can be passed to a formaldef,
but it is not the prefered way }
if not is_constnode(fromnode) then
eq:=te_convert_l2
else
eq:=te_incompatible;
end;
orddef :
begin
{ allows conversion from word to integer and
byte to shortint, but only for TP7 compatibility }
if (m_tp7 in current_settings.modeswitches) and
(def_from.typ=orddef) and
(def_from.size=def_to.size) then
eq:=te_convert_l1;
end;
arraydef :
begin
if is_open_array(def_to) then
begin
if is_dynamic_array(def_from) and
equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then
eq:=te_convert_l2
else
if equal_defs(def_from,tarraydef(def_to).elementdef) then
eq:=te_convert_l2;
end;
end;
pointerdef :
begin
{ an implicit pointer conversion is allowed }
if (def_from.typ=pointerdef) then
eq:=te_convert_l1;
end;
stringdef :
begin
{ all shortstrings are allowed, size is not important }
if is_shortstring(def_from) and
is_shortstring(def_to) then
eq:=te_equal;
end;
objectdef :
begin
{ child objects can be also passed }
{ in non-delphi mode, otherwise }
{ they must match exactly, except }
{ if they are objects }
if (def_from.typ=objectdef) and
(
(tobjectdef(def_from).objecttype=odt_object) and
(tobjectdef(def_to).objecttype=odt_object)
) and
(tobjectdef(def_from).is_related(tobjectdef(def_to))) then
eq:=te_convert_l1;
end;
filedef :
begin
{ an implicit file conversion is also allowed }
{ from a typed file to an untyped one }
if (def_from.typ=filedef) and
(tfiledef(def_from).filetyp = ft_typed) and
(tfiledef(def_to).filetyp = ft_untyped) then
eq:=te_convert_l1;
end;
end;
end;
procedure para_allowed(var eq:tequaltype;p:tcallparanode;def_to:tdef);
begin
{ Note: eq must be already valid, it will only be updated! }
case def_to.typ of
formaldef :
begin
{ all types can be passed to a formaldef }
eq:=te_equal;
end;
stringdef :
begin
{ to support ansi/long/wide strings in a proper way }
{ string and string[10] are assumed as equal }
{ when searching the correct overloaded procedure }
if (p.resultdef.typ=stringdef) and
(tstringdef(def_to).stringtype=tstringdef(p.resultdef).stringtype) then
eq:=te_equal
else
{ Passing a constant char to ansistring or shortstring or
a widechar to widestring then handle it as equal. }
if (p.left.nodetype=ordconstn) and
(
is_char(p.resultdef) and
(is_shortstring(def_to) or is_ansistring(def_to))
) or
(
is_widechar(p.resultdef) and
(is_widestring(def_to) or is_unicodestring(def_to))
) then
eq:=te_equal
end;
setdef :
begin
{ set can also be a not yet converted array constructor }
if (p.resultdef.typ=arraydef) and
is_array_constructor(p.resultdef) and
not is_variant_array(p.resultdef) then
eq:=te_equal;
end;
procvardef :
begin
{ in tp7 mode proc -> procvar is allowed }
if ((m_tp_procvar in current_settings.modeswitches) or
(m_mac_procvar in current_settings.modeswitches)) and
(p.left.nodetype=calln) and
(proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def_to))>=te_equal) then
eq:=te_equal
else
if (m_mac_procvar in current_settings.modeswitches) and
is_procvar_load(p.left) then
eq:=te_convert_l2;
end;
end;
end;
function allowenumop(nt:tnodetype):boolean;
begin
result:=(nt in [equaln,unequaln,ltn,lten,gtn,gten]) or
((cs_allow_enum_calc in current_settings.localswitches) and
(nt in [addn,subn]));
end;
{****************************************************************************
TCallCandidates
****************************************************************************}
constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas:boolean);
begin
if not assigned(sym) then
internalerror(200411015);
FOperator:=NOTOKEN;
FProcsym:=sym;
FProcsymtable:=st;
FParanode:=ppn;
create_candidate_list(ignorevisibility,allowdefaultparas);
end;
constructor tcallcandidates.create_operator(op:ttoken;ppn:tnode);
begin
FOperator:=op;
FProcsym:=nil;
FProcsymtable:=nil;
FParanode:=ppn;
create_candidate_list(false,false);
end;
destructor tcallcandidates.destroy;
var
hpnext,
hp : pcandidate;
begin
hp:=FCandidateProcs;
while assigned(hp) do
begin
hpnext:=hp^.next;
dispose(hp);
hp:=hpnext;
end;
end;
procedure tcallcandidates.collect_overloads_in_class(ProcdefOverloadList:TFPObjectList);
var
j : integer;
pd : tprocdef;
srsym : tsym;
objdef : tobjectdef;
hashedid : THashedIDString;
hasoverload : boolean;
begin
objdef:=tobjectdef(fprocsym.owner.defowner);
hashedid.id:=fprocsym.name;
hasoverload:=false;
while assigned(objdef) do
begin
srsym:=tprocsym(objdef.symtable.FindWithHash(hashedid));
if assigned(srsym) then
begin
if (srsym.typ<>procsym) then
internalerror(200111022);
{ add all definitions }
hasoverload:=false;
for j:=0 to tprocsym(srsym).ProcdefList.Count-1 do
begin
pd:=tprocdef(tprocsym(srsym).ProcdefList[j]);
if po_overload in pd.procoptions then
hasoverload:=true;
ProcdefOverloadList.Add(tprocsym(srsym).ProcdefList[j]);
end;
{ when there is no explicit overload we stop searching }
if not hasoverload then
break;
end;
{ next parent }
objdef:=objdef.childof;
end;
end;
procedure tcallcandidates.collect_overloads_in_units(ProcdefOverloadList:TFPObjectList);
var
j : integer;
pd : tprocdef;
srsymtable : TSymtable;
srsym : tsym;
checkstack : psymtablestackitem;
hashedid : THashedIDString;
hasoverload : boolean;
begin
{ we search all overloaded operator definitions in the symtablestack. The found
entries are only added to the procs list and not the procsym, because
the list can change in every situation }
if FOperator<>NOTOKEN then
hashedid.id:=overloaded_names[FOperator]
else
hashedid.id:=FProcsym.name;
checkstack:=symtablestack.stack;
if assigned(FProcsymtable) then
begin
while assigned(checkstack) and
(checkstack^.symtable<>FProcsymtable) do
checkstack:=checkstack^.next;
end;
while assigned(checkstack) do
begin
srsymtable:=checkstack^.symtable;
if srsymtable.symtabletype in [localsymtable,staticsymtable,globalsymtable] then
begin
srsym:=tprocsym(srsymtable.FindWithHash(hashedid));
if assigned(srsym) and
(srsym.typ=procsym) then
begin
{ Store first procsym found }
if not assigned(FProcsym) then
FProcsym:=tprocsym(srsym);
{ add all definitions }
hasoverload:=false;
for j:=0 to tprocsym(srsym).ProcdefList.Count-1 do
begin
pd:=tprocdef(tprocsym(srsym).ProcdefList[j]);
if po_overload in pd.procoptions then
hasoverload:=true;
ProcdefOverloadList.Add(tprocsym(srsym).ProcdefList[j]);
end;
{ when there is no explicit overload we stop searching }
if not hasoverload then
break;
end;
end;
checkstack:=checkstack^.next;
end;
end;
procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas:boolean);
var
j : integer;
pd : tprocdef;
hp : pcandidate;
pt : tcallparanode;
found : boolean;
contextobjdef : tobjectdef;
ProcdefOverloadList : TFPObjectList;
begin
FCandidateProcs:=nil;
{ Find all available overloads for this procsym }
ProcdefOverloadList:=TFPObjectList.Create(false);
if (FOperator=NOTOKEN) and
(FProcsym.owner.symtabletype=objectsymtable) then
collect_overloads_in_class(ProcdefOverloadList)
else
collect_overloads_in_units(ProcdefOverloadList);
{ determine length of parameter list.
for operators also enable the variant-operators if
a variant parameter is passed }
FParalength:=0;
FAllowVariant:=(FOperator=NOTOKEN);
pt:=tcallparanode(FParaNode);
while assigned(pt) do
begin
if (pt.resultdef.typ=variantdef) then
FAllowVariant:=true;
inc(FParalength);
pt:=tcallparanode(pt.right);
end;
{ when the class passed is defined in this unit we
need to use the scope of that class. This is a trick
that can be used to access protected members in other
units. At least kylix supports it this way (PFV) }
if assigned(FProcSymtable) and
(
(FProcSymtable.symtabletype=ObjectSymtable) or
((FProcSymtable.symtabletype=withsymtable) and
(FProcSymtable.defowner.typ=objectdef))
) and
(FProcSymtable.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
FProcSymtable.defowner.owner.iscurrentunit then
contextobjdef:=tobjectdef(FProcSymtable.defowner)
else
contextobjdef:=current_objectdef;
{ Process all found overloads }
for j:=0 to ProcdefOverloadList.Count-1 do
begin
pd:=tprocdef(ProcdefOverloadList[j]);
{ only when the # of parameter are supported by the procedure and
it is visible }
if (FParalength>=pd.minparacount) and
(
(
allowdefaultparas and
(
(FParalength<=pd.maxparacount) or
(po_varargs in pd.procoptions)
)
) or
(
not allowdefaultparas and
(FParalength=pd.maxparacount)
)
) and
(
ignorevisibility or
(pd.owner.symtabletype<>objectsymtable) or
is_visible_for_object(pd,contextobjdef)
) then
begin
{ don't add duplicates, only compare visible parameters for the user }
found:=false;
hp:=FCandidateProcs;
while assigned(hp) do
begin
if compare_paras(hp^.data.paras,pd.paras,cp_value_equal_const,[cpo_ignorehidden])>=te_equal then
begin
found:=true;
break;
end;
hp:=hp^.next;
end;
if not found then
proc_add(fprocsym,pd);
end;
end;
ProcdefOverloadList.Free;
end;
function tcallcandidates.proc_add(ps:tprocsym;pd:tprocdef):pcandidate;
var
defaultparacnt : integer;
begin
{ generate new candidate entry }
new(result);
fillchar(result^,sizeof(tcandidate),0);
result^.data:=pd;
result^.next:=FCandidateProcs;
FCandidateProcs:=result;
inc(FProccnt);
{ Find last parameter, skip all default parameters
that are not passed. Ignore this skipping for varargs }
result^.firstparaidx:=pd.paras.count-1;
if not(po_varargs in pd.procoptions) then
begin
{ ignore hidden parameters }
while (result^.firstparaidx>=0) and (vo_is_hidden_para in tparavarsym(pd.paras[result^.firstparaidx]).varoptions) do
dec(result^.firstparaidx);
defaultparacnt:=pd.maxparacount-FParalength;
if defaultparacnt>0 then
begin
if defaultparacnt>result^.firstparaidx+1 then
internalerror(200401141);
dec(result^.firstparaidx,defaultparacnt);
end;
end;
{ Give a small penalty for overloaded methods not in
defined the current class/unit }
if ps.owner<>pd.owner then
result^.ordinal_distance:=result^.ordinal_distance+1.0;
end;
procedure tcallcandidates.list(all:boolean);
var
hp : pcandidate;
begin
hp:=FCandidateProcs;
while assigned(hp) do
begin
if all or
(not hp^.invalid) then
MessagePos1(hp^.data.fileinfo,sym_h_param_list,hp^.data.fullprocname(false));
hp:=hp^.next;
end;
end;
{$ifdef EXTDEBUG}
procedure tcallcandidates.dump_info(lvl:longint);
function ParaTreeStr(p:tcallparanode):string;
begin
result:='';
while assigned(p) do
begin
if result<>'' then
result:=','+result;
result:=p.resultdef.typename+result;
p:=tcallparanode(p.right);
end;
end;
var
hp : pcandidate;
i : integer;
currpara : tparavarsym;
begin
if not CheckVerbosity(lvl) then
exit;
Comment(lvl+V_LineInfo,'Overloaded callnode: '+FProcsym.name+'('+ParaTreeStr(tcallparanode(FParaNode))+')');
hp:=FCandidateProcs;
while assigned(hp) do
begin
Comment(lvl,' '+hp^.data.fullprocname(false));
if (hp^.invalid) then
Comment(lvl,' invalid')
else
begin
Comment(lvl,' ex: '+tostr(hp^.exact_count)+
' eq: '+tostr(hp^.equal_count)+
' l1: '+tostr(hp^.cl1_count)+
' l2: '+tostr(hp^.cl2_count)+
' l3: '+tostr(hp^.cl3_count)+
' l4: '+tostr(hp^.cl4_count)+
' l5: '+tostr(hp^.cl5_count)+
' oper: '+tostr(hp^.coper_count)+
' ord: '+realtostr(hp^.ordinal_distance));
{ Print parameters in left-right order }
for i:=0 to hp^.data.paras.count-1 do
begin
currpara:=tparavarsym(hp^.data.paras[i]);
if not(vo_is_hidden_para in currpara.varoptions) then
Comment(lvl,' - '+currpara.vardef.typename+' : '+EqualTypeName[currpara.eqval]);
end;
end;
hp:=hp^.next;
end;
end;
{$endif EXTDEBUG}
procedure tcallcandidates.get_information;
var
hp : pcandidate;
currpara : tparavarsym;
paraidx : integer;
currparanr : byte;
rfh,rth : double;
objdef : tobjectdef;
def_from,
def_to : tdef;
currpt,
pt : tcallparanode;
eq : tequaltype;
convtype : tconverttype;
pdtemp,
pdoper : tprocdef;
releasecurrpt : boolean;
cdoptions : tcompare_defs_options;
n : tnode;
{$ifopt r+}{$define ena_r}{$r-}{$endif}
{$ifopt q+}{$define ena_q}{$q-}{$endif}
const
inf=1.0/0.0;
{$ifdef ena_r}{$r+}{$endif}
{$ifdef ena_q}{$q+}{$endif}
begin
cdoptions:=[cdo_check_operator];
if FAllowVariant then
include(cdoptions,cdo_allow_variant);
{ process all procs }
hp:=FCandidateProcs;
while assigned(hp) do
begin
{ We compare parameters in reverse order (right to left),
the firstpara is already pointing to the last parameter
were we need to start comparing }
currparanr:=FParalength;
paraidx:=hp^.firstparaidx;
while (paraidx>=0) and (vo_is_hidden_para in tparavarsym(hp^.data.paras[paraidx]).varoptions) do
dec(paraidx);
pt:=tcallparanode(FParaNode);
while assigned(pt) and (paraidx>=0) do
begin
currpara:=tparavarsym(hp^.data.paras[paraidx]);
{ currpt can be changed from loadn to calln when a procvar
is passed. This is to prevent that the change is permanent }
currpt:=pt;
releasecurrpt:=false;
{ retrieve current parameter definitions to compares }
eq:=te_incompatible;
def_from:=currpt.resultdef;
def_to:=currpara.vardef;
if not(assigned(def_from)) then
internalerror(200212091);
if not(
assigned(def_to) or
((po_varargs in hp^.data.procoptions) and
(currparanr>hp^.data.minparacount))
) then
internalerror(200212092);
{ Convert tp procvars when not expecting a procvar }
if (currpt.left.resultdef.typ=procvardef) and
not(def_to.typ in [procvardef,formaldef]) and
{ Only convert to call when there is no overload or the return type
is equal to the expected type. }
(
(count=1) or
equal_defs(tprocvardef(currpt.left.resultdef).returndef,def_to)
) then
begin
releasecurrpt:=true;
currpt:=tcallparanode(pt.getcopy);
if maybe_call_procvar(currpt.left,true) then
begin
currpt.resultdef:=currpt.left.resultdef;
def_from:=currpt.left.resultdef;
end;
end;
{ If we expect a procvar and the left is loadnode that
returns a procdef we need to find the correct overloaded
procdef that matches the expected procvar. The loadnode
temporary returned the first procdef (PFV) }
if (def_to.typ=procvardef) and
(currpt.left.nodetype=loadn) and
(currpt.left.resultdef.typ=procdef) then
begin
pdtemp:=tprocsym(Tloadnode(currpt.left).symtableentry).Find_procdef_byprocvardef(Tprocvardef(def_to));
if assigned(pdtemp) then
begin
tloadnode(currpt.left).setprocdef(pdtemp);
currpt.resultdef:=currpt.left.resultdef;
def_from:=currpt.left.resultdef;
end;
end;
{ varargs are always equal, but not exact }
if (po_varargs in hp^.data.procoptions) and
(currparanr>hp^.data.minparacount) and
not is_array_of_const(def_from) and
not is_array_constructor(def_from) then
eq:=te_equal
else
{ same definition -> exact }
if (def_from=def_to) then
eq:=te_exact
else
{ for value and const parameters check if a integer is constant or
included in other integer -> equal and calc ordinal_distance }
if not(currpara.varspez in [vs_var,vs_out]) and
is_integer(def_from) and
is_integer(def_to) and
is_in_limit(def_from,def_to) then
begin
eq:=te_equal;
hp^.ordinal_distance:=hp^.ordinal_distance+
abs(bestreal(torddef(def_from).low)-bestreal(torddef(def_to).low));
rth:=bestreal(torddef(def_to).high);
rfh:=bestreal(torddef(def_from).high);
hp^.ordinal_distance:=hp^.ordinal_distance+abs(rth-rfh);
{ Give wrong sign a small penalty, this is need to get a diffrence
from word->[longword,longint] }
if is_signed(def_from)<>is_signed(def_to) then
{$ifopt r+}{$define ena_rq}{$q-}{$r-}{$endif}
hp^.ordinal_distance:=nextafter(hp^.ordinal_distance,inf);
{$ifdef ena_rq}{$r+}{$q+}{$endif}
end
else
{ for value and const parameters check precision of real, give
penalty for loosing of precision. var and out parameters must match exactly }
if not(currpara.varspez in [vs_var,vs_out]) and
is_real(def_from) and
is_real(def_to) then
begin
eq:=te_equal;
if is_extended(def_to) then
rth:=4
else
if is_double (def_to) then
rth:=2
else
rth:=1;
if is_extended(def_from) then
rfh:=4
else
if is_double (def_from) then
rfh:=2
else
rfh:=1;
{ penalty for shrinking of precision }
if rth<rfh then
rfh:=(rfh-rth)*16
else
rfh:=rth-rfh;
hp^.ordinal_distance:=hp^.ordinal_distance+rfh;
end
else
{ related object parameters also need to determine the distance between the current
object and the object we are comparing with. var and out parameters must match exactly }
if not(currpara.varspez in [vs_var,vs_out]) and
(def_from.typ=objectdef) and
(def_to.typ=objectdef) and
(tobjectdef(def_from).objecttype=tobjectdef(def_to).objecttype) and
tobjectdef(def_from).is_related(tobjectdef(def_to)) then
begin
eq:=te_convert_l1;
objdef:=tobjectdef(def_from);
while assigned(objdef) do
begin
if objdef=def_to then
break;
hp^.ordinal_distance:=hp^.ordinal_distance+1;
objdef:=objdef.childof;
end;
end
{ compare_defs_ext compares sets and array constructors very poorly because
it has too little information. So we do explicitly a detailed comparisation,
see also bug #11288 (FK)
}
else if (def_to.typ=setdef) and is_array_constructor(currpt.left.resultdef) then
begin
n:=currpt.left.getcopy;
arrayconstructor_to_set(n);
eq:=compare_defs_ext(n.resultdef,def_to,n.nodetype,convtype,pdoper,cdoptions);
n.free;
end
else
{ generic type comparision }
begin
eq:=compare_defs_ext(def_from,def_to,currpt.left.nodetype,convtype,pdoper,cdoptions);
{ when the types are not equal we need to check
some special case for parameter passing }
if (eq<te_equal) then
begin
if currpara.varspez in [vs_var,vs_out] then
begin
{ para requires an equal type so the previous found
match was not good enough, reset to incompatible }
eq:=te_incompatible;
{ var_para_allowed will return te_equal and te_convert_l1 to
make a difference for best matching }
var_para_allowed(eq,currpt.resultdef,currpara.vardef,currpt.left)
end
else
para_allowed(eq,currpt,def_to);
end;
end;
{ when a procvar was changed to a call an exact much is
downgraded to equal. This way an overload call with the
procvar is choosen. See tb0471 (PFV) }
if (pt<>currpt) and (eq=te_exact) then
eq:=te_equal;
{ increase correct counter }
case eq of
te_exact :
inc(hp^.exact_count);
te_equal :
inc(hp^.equal_count);
te_convert_l1 :
inc(hp^.cl1_count);
te_convert_l2 :
inc(hp^.cl2_count);
te_convert_l3 :
inc(hp^.cl3_count);
te_convert_l4 :
inc(hp^.cl4_count);
te_convert_l5 :
inc(hp^.cl5_count);
te_convert_operator :
inc(hp^.coper_count);
te_incompatible :
hp^.invalid:=true;
else
internalerror(200212072);
end;
{ stop checking when an incompatible parameter is found }
if hp^.invalid then
begin
{ store the current parameter info for
a nice error message when no procedure is found }
hp^.wrongparaidx:=paraidx;
hp^.wrongparanr:=currparanr;
break;
end;
{$ifdef EXTDEBUG}
{ store equal in node tree for dump }
currpara.eqval:=eq;
{$endif EXTDEBUG}
{ maybe release temp currpt }
if releasecurrpt then
currpt.free;
{ next parameter in the call tree }
pt:=tcallparanode(pt.right);
{ next parameter for definition, only goto next para
if we're out of the varargs }
if not(po_varargs in hp^.data.procoptions) or
(currparanr<=hp^.data.maxparacount) then
begin
{ Ignore vs_hidden parameters }
repeat
dec(paraidx);
until (paraidx<0) or not(vo_is_hidden_para in tparavarsym(hp^.data.paras[paraidx]).varoptions);
end;
dec(currparanr);
end;
if not(hp^.invalid) and
(assigned(pt) or (paraidx>=0) or (currparanr<>0)) then
internalerror(200212141);
{ next candidate }
hp:=hp^.next;
end;
end;
function get_variantequaltype(def: tdef): tvariantequaltype;
const
variantorddef_cl: array[tordtype] of tvariantequaltype =
(tve_incompatible,tve_byte,tve_word,tve_cardinal,tve_chari64,
tve_shortint,tve_smallint,tve_longint,tve_chari64,
tve_boolformal,tve_boolformal,tve_boolformal,tve_boolformal,tve_boolformal,
tve_chari64,tve_chari64,tve_dblcurrency);
{ TODO: fixme for 128 bit floats }
variantfloatdef_cl: array[tfloattype] of tvariantequaltype =
(tve_single,tve_dblcurrency,tve_extended,
tve_dblcurrency,tve_dblcurrency,tve_extended);
variantstringdef_cl: array[tstringtype] of tvariantequaltype =
(tve_sstring,tve_astring,tve_astring,tve_wstring,tve_ustring);
begin
case def.typ of
orddef:
begin
result:=variantorddef_cl[torddef(def).ordtype];
end;
floatdef:
begin
result:=variantfloatdef_cl[tfloatdef(def).floattype];
end;
stringdef:
begin
result:=variantstringdef_cl[tstringdef(def).stringtype];
end;
formaldef:
begin
result:=tve_boolformal;
end;
else
begin
result:=tve_incompatible;
end;
end
end;
function is_better_candidate(currpd,bestpd:pcandidate):integer;
var
res : integer;
begin
{
Return values:
> 0 when currpd is better than bestpd
< 0 when bestpd is better than currpd
= 0 when both are equal
To choose the best candidate we use the following order:
- Incompatible flag
- (Smaller) Number of convert operator parameters.
- (Smaller) Number of convertlevel 2 parameters.
- (Smaller) Number of convertlevel 1 parameters.
- (Bigger) Number of exact parameters.
- (Smaller) Number of equal parameters.
- (Smaller) Total of ordinal distance. For example, the distance of a word
to a byte is 65535-255=65280.
}
if bestpd^.invalid then
begin
if currpd^.invalid then
res:=0
else
res:=1;
end
else
if currpd^.invalid then
res:=-1
else
begin
{ less operator parameters? }
res:=(bestpd^.coper_count-currpd^.coper_count);
if (res=0) then
begin
{ less cl5 parameters? }
res:=(bestpd^.cl5_count-currpd^.cl5_count);
if (res=0) then
begin
{ less cl4 parameters? }
res:=(bestpd^.cl4_count-currpd^.cl4_count);
if (res=0) then
begin
{ less cl3 parameters? }
res:=(bestpd^.cl3_count-currpd^.cl3_count);
if (res=0) then
begin
{ less cl2 parameters? }
res:=(bestpd^.cl2_count-currpd^.cl2_count);
if (res=0) then
begin
{ less cl1 parameters? }
res:=(bestpd^.cl1_count-currpd^.cl1_count);
if (res=0) then
begin
{ more exact parameters? }
res:=(currpd^.exact_count-bestpd^.exact_count);
if (res=0) then
begin
{ less equal parameters? }
res:=(bestpd^.equal_count-currpd^.equal_count);
if (res=0) then
begin
{ smaller ordinal distance? }
if (currpd^.ordinal_distance<bestpd^.ordinal_distance) then
res:=1
else
if (currpd^.ordinal_distance>bestpd^.ordinal_distance) then
res:=-1
else
res:=0;
end;
end;
end;
end;
end;
end;
end;
end;
end;
is_better_candidate:=res;
end;
{ Delphi precedence rules extracted from test programs. Only valid if passing
a variant parameter to overloaded procedures expecting exactly one parameter.
single > (char, currency, int64, shortstring, ansistring, widestring, extended, double)
double/currency > (char, int64, shortstring, ansistring, widestring, extended)
extended > (char, int64, shortstring, ansistring, widestring)
longint/cardinal > (int64, shortstring, ansistring, widestring, extended, double, single, char, currency)
smallint > (longint, int64, shortstring, ansistring, widestring, extended, double single, char, currency);
word > (longint, cardinal, int64, shortstring, ansistring, widestring, extended, double single, char, currency);
shortint > (longint, smallint, int64, shortstring, ansistring, widestring, extended, double, single, char, currency)
byte > (longint, cardinal, word, smallint, int64, shortstring, ansistring, widestring, extended, double, single, char, currency);
boolean/formal > (char, int64, shortstring, ansistring, widestring)
shortstring > (char, int64, ansistring, widestring)
ansistring > (char, int64, widestring)
widestring > (char, int64)
Relations not mentioned mean that they conflict: no decision possible }
function is_better_candidate_single_variant(currpd,bestpd:pcandidate):integer;
function calculate_relation(const currvcl, bestvcl, testvcl:
tvariantequaltype; const conflictvcls: tvariantequaltypes):integer;
begin
{ if (bestvcl=conflictvcl) or
(currvcl=conflictvcl) then
result:=0
else if (bestvcl=testvcl) then
result:=-1
else result:=1 }
result:=1-2*ord(bestvcl=testvcl)+
ord(currvcl in conflictvcls)-ord(bestvcl in conflictvcls);
end;
function getfirstrealparaidx(pd: pcandidate): integer;
begin
{ can be different for currpd and bestpd in case of overloaded }
{ functions, e.g. lowercase():char and lowercase():shortstring }
{ (depending on the calling convention and parameter order) }
result:=pd^.firstparaidx;
while (result>=0) and (vo_is_hidden_para in tparavarsym(pd^.data.paras[result]).varoptions) do
dec(result);
if (vo_is_hidden_para in tparavarsym(pd^.data.paras[result]).varoptions) then
internalerror(2006122803);
end;
var
currpara, bestpara: tparavarsym;
currvcl, bestvcl: tvariantequaltype;
begin
{
Return values:
> 0 when currpd is better than bestpd
< 0 when bestpd is better than currpd
= 0 when both are equal
}
currpara:=tparavarsym(currpd^.data.paras[getfirstrealparaidx(currpd)]);
bestpara:=tparavarsym(bestpd^.data.paras[getfirstrealparaidx(bestpd)]);
{ if one of the parameters is a regular variant, fall back to the }
{ default algorithm }
if (currpara.vardef.typ = variantdef) or
(bestpara.vardef.typ = variantdef) then
begin
result:=is_better_candidate(currpd,bestpd);
exit;
end;
currvcl:=get_variantequaltype(currpara.vardef);
bestvcl:=get_variantequaltype(bestpara.vardef);
{ sanity check }
result:=-5;
{ if both are the same, there is a conflict }
if (currvcl=bestvcl) then
result:=0
{ if one of the two cannot be used as variant, the other is better }
else if (bestvcl=tve_incompatible) then
result:=1
else if (currvcl=tve_incompatible) then
result:=-1
{ boolean and formal are better than chari64str, but conflict with }
{ everything else }
else if (currvcl=tve_boolformal) or
(bestvcl=tve_boolformal) then
if (currvcl=tve_boolformal) then
result:=ord(bestvcl in [tve_chari64,tve_sstring,tve_astring,tve_wstring,tve_ustring])
else
result:=-ord(currvcl in [tve_chari64,tve_sstring,tve_astring,tve_wstring,tve_ustring])
{ byte is better than everything else (we assume both aren't byte, }
{ since there's only one parameter and that one can't be the same) }
else if (currvcl=tve_byte) or
(bestvcl=tve_byte) then
result:=calculate_relation(currvcl,bestvcl,tve_byte,[tve_shortint])
{ shortint conflicts with word and cardinal, but is better than }
{ everything else but byte (which has already been handled) }
else if (currvcl=tve_shortint) or
(bestvcl=tve_shortint) then
result:=calculate_relation(currvcl,bestvcl,tve_shortint,[tve_word, tve_cardinal])
{ word conflicts with smallint, but is better than everything else }
{ but shortint and byte (which has already been handled) }
else if (currvcl=tve_word) or
(bestvcl=tve_word) then
result:=calculate_relation(currvcl,bestvcl,tve_word,[tve_smallint])
{ smallint conflicts with cardinal, but is better than everything }
{ which has not yet been tested }
else if (currvcl=tve_smallint) or
(bestvcl=tve_smallint) then
result:=calculate_relation(currvcl,bestvcl,tve_smallint,[tve_cardinal])
{ cardinal conflicts with each longint and is better than everything }
{ which has not yet been tested }
else if (currvcl=tve_cardinal) or
(bestvcl=tve_cardinal) then
result:=calculate_relation(currvcl,bestvcl,tve_cardinal,[tve_longint])
{ longint is better than everything which has not yet been tested }
else if (currvcl=tve_longint) or
(bestvcl=tve_longint) then
{ if bestvcl=tve_longint then
result:=-1
else
result:=1 }
result:=1-2*ord(bestvcl=tve_longint)
{ single is better than everything left }
else if (currvcl=tve_single) or
(bestvcl=tve_single) then
result:=1-2*ord(bestvcl=tve_single)
{ double/comp/currency are better than everything left, and conflict }
{ with each other (but that's already tested) }
else if (currvcl=tve_dblcurrency) or
(bestvcl=tve_dblcurrency) then
result:=1-2*ord(bestvcl=tve_dblcurrency)
{ extended is better than everything left }
else if (currvcl=tve_extended) or
(bestvcl=tve_extended) then
result:=1-2*ord(bestvcl=tve_extended)
{ shortstring is better than everything left }
else if (currvcl=tve_sstring) or
(bestvcl=tve_sstring) then
result:=1-2*ord(bestvcl=tve_sstring)
{ ansistring is better than everything left }
else if (currvcl=tve_astring) or
(bestvcl=tve_astring) then
result:=1-2*ord(bestvcl=tve_astring)
{ widestring is better than everything left }
else if (currvcl=tve_wstring) or
(bestvcl=tve_wstring) then
result:=1-2*ord(bestvcl=tve_wstring)
{ unicodestring is better than everything left }
else if (currvcl=tve_ustring) or
(bestvcl=tve_ustring) then
result:=1-2*ord(bestvcl=tve_ustring);
{ all possibilities should have been checked now }
if (result=-5) then
internalerror(2006122805);
end;
function tcallcandidates.choose_best(var bestpd:tabstractprocdef; singlevariant: boolean):integer;
var
besthpstart,
hp : pcandidate;
cntpd,
res : integer;
begin
{
Returns the number of candidates left and the
first candidate is returned in pdbest
}
{ Setup the first procdef as best, only count it as a result
when it is valid }
bestpd:=FCandidateProcs^.data;
if FCandidateProcs^.invalid then
cntpd:=0
else
cntpd:=1;
if assigned(FCandidateProcs^.next) then
begin
besthpstart:=FCandidateProcs;
hp:=FCandidateProcs^.next;
while assigned(hp) do
begin
if not singlevariant then
res:=is_better_candidate(hp,besthpstart)
else
res:=is_better_candidate_single_variant(hp,besthpstart);
if (res>0) then
begin
{ hp is better, flag all procs to be incompatible }
while (besthpstart<>hp) do
begin
besthpstart^.invalid:=true;
besthpstart:=besthpstart^.next;
end;
{ besthpstart is already set to hp }
bestpd:=besthpstart^.data;
cntpd:=1;
end
else
if (res<0) then
begin
{ besthpstart is better, flag current hp to be incompatible }
hp^.invalid:=true;
end
else
begin
{ res=0, both are valid }
if not hp^.invalid then
inc(cntpd);
end;
hp:=hp^.next;
end;
end;
result:=cntpd;
end;
procedure tcallcandidates.find_wrong_para;
var
currparanr : smallint;
hp : pcandidate;
pt : tcallparanode;
wrongpara : tparavarsym;
begin
{ Only process the first overloaded procdef }
hp:=FCandidateProcs;
{ Find callparanode corresponding to the argument }
pt:=tcallparanode(FParanode);
currparanr:=FParalength;
while assigned(pt) and
(currparanr>hp^.wrongparanr) do
begin
pt:=tcallparanode(pt.right);
dec(currparanr);
end;
if (currparanr<>hp^.wrongparanr) or
not assigned(pt) then
internalerror(200212094);
{ Show error message, when it was a var or out parameter
guess that it is a missing typeconv }
wrongpara:=tparavarsym(hp^.data.paras[hp^.wrongparaidx]);
if wrongpara.varspez in [vs_var,vs_out] then
begin
{ Maybe passing the correct type but passing a const to var parameter }
if (compare_defs(pt.resultdef,wrongpara.vardef,pt.nodetype)<>te_incompatible) and
not valid_for_var(pt.left,true) then
CGMessagePos(pt.left.fileinfo,type_e_variable_id_expected)
else
CGMessagePos3(pt.left.fileinfo,parser_e_call_by_ref_without_typeconv,tostr(hp^.wrongparanr),
FullTypeName(pt.left.resultdef,wrongpara.vardef),
FullTypeName(wrongpara.vardef,pt.left.resultdef))
end
else
CGMessagePos3(pt.left.fileinfo,type_e_wrong_parameter_type,tostr(hp^.wrongparanr),
FullTypeName(pt.left.resultdef,wrongpara.vardef),
FullTypeName(wrongpara.vardef,pt.left.resultdef));
end;
procedure check_hints(const srsym: tsym; const symoptions: tsymoptions);
begin
if not assigned(srsym) then
internalerror(200602051);
if sp_hint_deprecated in symoptions then
Message1(sym_w_deprecated_symbol,srsym.realname);
if sp_hint_experimental in symoptions then
Message1(sym_w_experimental_symbol,srsym.realname);
if sp_hint_platform in symoptions then
Message1(sym_w_non_portable_symbol,srsym.realname);
if sp_hint_unimplemented in symoptions then
Message1(sym_w_non_implemented_symbol,srsym.realname);
end;
procedure check_ranges(const location: tfileposinfo; source: tnode; destdef: tdef);
begin
if not(cs_check_ordinal_size in current_settings.localswitches) then
exit;
{ check if the assignment may cause a range check error }
{ if its not explicit, and only if the values are }
{ ordinals, enumdef and floatdef }
if assigned(destdef) and
(destdef.typ in [enumdef,orddef,floatdef]) and
not is_boolean(destdef) and
assigned(source.resultdef) and
(source.resultdef.typ in [enumdef,orddef,floatdef]) and
not is_boolean(source.resultdef) and
not is_constrealnode(source) then
begin
if (destdef.size < source.resultdef.size) then
begin
if (cs_check_range in current_settings.localswitches) then
MessagePos(location,type_w_smaller_possible_range_check)
else
MessagePos(location,type_h_smaller_possible_range_check);
end;
end;
end;
end.
Reference in New Issue View Git Blame Copy Permalink