paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-01 07:33:40 +02:00
Code Issues Packages Projects Releases Wiki Activity
eccbc78e04
fpc/compiler/htypechk.pas
Jonas Maebe eccbc78e04 + support for bitpacked arrays: 
+ use {$bitpacking on/+} to change the meaning of "packed"
      into "bitpacked" for arrays. This is the default for MacPas.
      You can also define individual arrays as "bitpacked", but
      this is not encouraged since this keyword is not known by
      other compilers and therefore makes your code unportable.
    + pack(unpackedarray,index,packedarray) to pack
      length(packedarray) elements starting at
      unpackedarray[index] into packedarray.
    + unpack(packedarray,unpackedarray,index) to unpack
      packedarray into unpackedarray, with the first
      element being stored at unpackedarray[index]
  * todo:
    * "open packed arrays" and rtti for packed arrays are not
      yet supported
    * gdb does not properly support bitpacked arrays

git-svn-id: trunk@4449 -
2006-08-19 12:54:12 +00:00

2307 lines
86 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
tokens,cpuinfo,
node,globals,
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,
coper_count : integer; { should be signed }
ordinal_distance : bestreal;
invalid : boolean;
wrongparanr : byte;
end;
tcallcandidates = class
private
FProcSym : tprocsym;
FProcs : pcandidate;
FProcVisibleCnt,
FProcCnt : integer;
FParaNode : tnode;
FParaLength : smallint;
FAllowVariant : boolean;
function proc_add(pd:tprocdef):pcandidate;
public
constructor create(sym:tprocsym;st:tsymtable;ppn:tnode;isprop,ignorevis : 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):integer;
procedure find_wrong_para;
property Count:integer read FProcCnt;
property VisibleCount:integer read FProcVisibleCnt;
end;
const
tok2nodes=25;
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:_CARET ;nod:caretn;op_overloading_supported:false), { binary overloading NOT supported }
(tok:_UNEQUAL ;nod:unequaln;op_overloading_supported:false) { binary overloading NOT supported overload = instead }
);
const
{ firstcallparan without varspez we don't count the ref }
{$ifdef extdebug}
count_ref : boolean = true;
{$endif def extdebug}
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: tvarregable);
procedure calcregisters(p : tbinarynode;r32,fpu,mmx : word);
{ 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
globtype,systems,
cutils,verbose,
symtable,
defutil,defcmp,
nbas,ncnv,nld,nmem,ncal,nmat,ninl,nutils,
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.deftype of
formaldef,
recorddef,
variantdef :
begin
allowed:=true;
end;
procvardef :
begin
if (rd.deftype in [pointerdef,procdef,procvardef]) then
begin
allowed:=false;
exit;
end;
allowed:=true;
end;
pointerdef :
begin
if ((rd.deftype 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.deftype=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 mmx }
if (cs_mmx in aktlocalswitches) and
is_mmx_able_array(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.deftype 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.deftype 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.deftype in [orddef,enumdef,floatdef]) then
exit;
{$ifdef SUPPORT_MMX}
if (cs_mmx in aktlocalswitches) and
is_mmx_able_array(ld) then
exit;
{$endif SUPPORT_MMX}
result:=true;
end;
notn :
begin
if (ld.deftype in [orddef,enumdef,floatdef]) then
exit;
{$ifdef SUPPORT_MMX}
if (cs_mmx in aktlocalswitches) 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;
begin
result:=false;
case pf.parast.symindex.count of
1 : begin
ld:=tparavarsym(pf.parast.symindex.first).vartype.def;
{ assignment is a special case }
if optoken=_ASSIGNMENT then
begin
eq:=compare_defs_ext(ld,pf.rettype.def,nothingn,conv,pd,[cdo_explicit]);
result:=(eq=te_incompatible);
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.symindex.first).vartype.def;
rd:=tparavarsym(pf.parast.symindex.first.indexnext).vartype.def;
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.resulttype.def;
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(operpd);
{ 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.det_resulttype }
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.resulttype.def;
rd:=tbinarynode(t).right.resulttype.def;
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(operpd);
{ 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.det_resulttype }
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: tvarregable; records_only: boolean);
begin
case p.nodetype of
subscriptn:
make_not_regable_intern(tsubscriptnode(p).left,how,true);
typeconvn :
if (ttypeconvnode(p).resulttype.def.deftype = recorddef) then
make_not_regable_intern(ttypeconvnode(p).left,how,false)
else
make_not_regable_intern(ttypeconvnode(p).left,how,records_only);
loadn :
if (tloadnode(p).symtableentry.typ in [globalvarsym,localvarsym,paravarsym]) and
(tabstractvarsym(tloadnode(p).symtableentry).varregable <> vr_none) and
((not records_only) or
(tabstractvarsym(tloadnode(p).symtableentry).vartype.def.deftype = recorddef)) then
if (tloadnode(p).symtableentry.typ = paravarsym) then
tabstractvarsym(tloadnode(p).symtableentry).varregable:=how
else
tabstractvarsym(tloadnode(p).symtableentry).varregable:=vr_none;
end;
end;
procedure make_not_regable(p : tnode; how: tvarregable);
begin
make_not_regable_intern(p,how,false);
end;
{ calculates the needed registers for a binary operator }
procedure calcregisters(p : tbinarynode;r32,fpu,mmx : word);
begin
p.left_right_max;
{ Only when the difference between the left and right registers < the
wanted registers allocate the amount of registers }
if assigned(p.left) then
begin
if assigned(p.right) then
begin
{ the location must be already filled in because we need it to }
{ calculate the necessary number of registers (JM) }
if p.expectloc = LOC_INVALID then
internalerror(200110101);
if (abs(p.left.registersint-p.right.registersint)<r32) or
((p.expectloc = LOC_FPUREGISTER) and
(p.right.registersfpu <= p.left.registersfpu) and
((p.right.registersfpu <> 0) or (p.left.registersfpu <> 0)) and
(p.left.registersint < p.right.registersint)) then
inc(p.registersint,r32);
if (abs(p.left.registersfpu-p.right.registersfpu)<fpu) then
inc(p.registersfpu,fpu);
{$ifdef SUPPORT_MMX}
if (abs(p.left.registersmmx-p.right.registersmmx)<mmx) then
inc(p.registersmmx,mmx);
{$endif SUPPORT_MMX}
{ the following is a little bit guessing but I think }
{ it's the only way to solve same internalerrors: }
{ if the left and right node both uses registers }
{ and return a mem location, but the current node }
{ doesn't use an integer register we get probably }
{ trouble when restoring a node }
if (p.left.registersint=p.right.registersint) and
(p.registersint=p.left.registersint) and
(p.registersint>0) and
(p.left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE]) and
(p.right.expectloc in [LOC_REFERENCE,LOC_CREFERENCE]) then
inc(p.registersint);
end
else
begin
if (p.left.registersint<r32) then
inc(p.registersint,r32);
if (p.left.registersfpu<fpu) then
inc(p.registersfpu,fpu);
{$ifdef SUPPORT_MMX}
if (p.left.registersmmx<mmx) then
inc(p.registersmmx,mmx);
{$endif SUPPORT_MMX}
end;
end;
end;
{****************************************************************************
Subroutine Handling
****************************************************************************}
function is_procvar_load(p:tnode):boolean;
begin
result:=false;
{ remove voidpointer typecast for tp procvars }
if ((m_tp_procvar in aktmodeswitches) or
(m_mac_procvar in aktmodeswitches)) and
(p.nodetype=typeconvn) and
is_voidpointer(p.resulttype.def) 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.deftype=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_written,vs_readwritten),
{ vs_declared -> ... }
(vs_none,vs_declared,vs_initialised,vs_read,vs_read_not_warned,vs_written,vs_readwritten),
{ vs_initialised -> ... }
(vs_none,vs_initialised,vs_initialised,vs_read,vs_read,vs_written,vs_readwritten),
{ vs_read -> ... }
(vs_none,vs_read,vs_read,vs_read,vs_read_not_warned,vs_readwritten,vs_readwritten),
{ vs_read_not_warned -> ... }
(vs_none,vs_read_not_warned,vs_read,vs_read,vs_read_not_warned,vs_readwritten,vs_readwritten),
{ vs_written -> ... }
(vs_none,vs_written,vs_written,vs_readwritten,vs_readwritten,vs_written,vs_readwritten),
{ vs_readwritten -> ... }
(vs_none,vs_readwritten,vs_readwritten,vs_readwritten,vs_readwritten,vs_readwritten,vs_readwritten));
var
hsym : tabstractvarsym;
begin
while assigned(p) do
begin
case p.nodetype of
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.resulttype.def) 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.resulttype.def.deftype 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,globalvarsym]) then
begin
hsym:=tabstractvarsym(tloadnode(p).symtableentry);
if (vsf_must_be_valid in varstateflags) and
(hsym.varstate in [vs_declared,vs_read_not_warned]) then
begin
{ Give warning/note for uninitialized locals }
if assigned(hsym.owner) 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
CGMessage(sym_h_function_result_uninitialized)
else
CGMessage(sym_w_function_result_uninitialized)
end
else
begin
if tloadnode(p).symtable.symtabletype=localsymtable then
begin
if (vsf_use_hints in varstateflags) then
CGMessage1(sym_h_uninitialized_local_variable,hsym.realname)
else
CGMessage1(sym_w_uninitialized_local_variable,hsym.realname);
end
else
begin
if (vsf_use_hints in varstateflags) then
CGMessage1(sym_h_uninitialized_variable,hsym.realname)
else
CGMessage1(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;
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
hp : tnode;
gotstring,
gotsubscript,
gotrecord,
gotpointer,
gotvec,
gotclass,
gotdynarray,
gotderef : boolean;
fromdef,
todef : tdef;
errmsg : longint;
begin
if valid_const in opts then
errmsg:=type_e_variable_id_expected
else
errmsg:=type_e_argument_cant_be_assigned;
result:=false;
gotsubscript:=false;
gotvec:=false;
gotderef:=false;
gotrecord:=false;
gotclass:=false;
gotpointer:=false;
gotdynarray:=false;
gotstring:=false;
hp:=p;
if not(valid_void in opts) and
is_void(hp.resulttype.def) 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
if (hp.nodetype=calln) then
begin
{ check return type }
case hp.resulttype.def.deftype of
pointerdef :
gotpointer:=true;
objectdef :
gotclass:=is_class_or_interface(hp.resulttype.def);
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
not(
(gotsubscript and gotrecord) or
(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) }
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=subscriptn)
) then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,errmsg);
end;
end
else
result:=true;
exit;
end;
if (Valid_Const in opts) and is_constnode(hp) then
begin
result:=true;
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
{ 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.resulttype.def;
todef:=hp.resulttype.def;
if not((nf_absolute in ttypeconvnode(hp).flags) or
(fromdef.deftype=formaldef) or
is_void(fromdef) or
is_open_array(fromdef) or
is_open_array(todef) or
((fromdef.deftype=pointerdef) and (todef.deftype=arraydef)) or
((fromdef.deftype = objectdef) and (todef.deftype = 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 aktmodeswitches) or
(todef.size<fromdef.size) then
make_not_regable(hp,vr_addr)
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.resulttype.def.deftype of
pointerdef :
gotpointer:=true;
objectdef :
gotclass:=is_class_or_interface(hp.resulttype.def);
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.resulttype.def.deftype=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.resulttype.def.deftype = arraydef) and
(ado_IsBitPacked in tarraydef(tvecnode(hp).left.resulttype.def).arrayoptions) then
begin
if report_errors then
CGMessagePos(hp.fileinfo,parser_e_packed_element_no_var_addr_loop);
exit;
end;
gotvec:=true;
{ accesses to dyn. arrays override read only access in delphi }
if (m_delphi in aktmodeswitches) and is_dynamic_array(tunarynode(hp).left.resulttype.def) then
gotdynarray:=true;
hp:=tunarynode(hp).left;
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
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.resulttype.def) 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.resulttype.def.deftype=pointerdef) or
(is_integer(hp.resulttype.def) and gotpointer)) and
gotderef then
result:=true
else
{ Temp strings are stored in memory, for compatibility with
delphi only }
if (m_delphi in aktmodeswitches) and
((valid_addr in opts) or
(valid_const in opts)) and
(hp.resulttype.def.deftype=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;
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.resulttype.def.deftype of
arraydef :
begin
{ dynamic arrays are allowed when there is also a
vec node }
if is_dynamic_array(hp.resulttype.def) and
gotvec then
begin
gotderef:=true;
gotpointer:=true;
end;
end;
pointerdef :
gotpointer:=true;
objectdef :
gotclass:=is_class_or_interface(hp.resulttype.def);
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 aktmodeswitches) and
(valid_addr in opts) and
(hp.resulttype.def.deftype=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;
loadn :
begin
case tloadnode(hp).symtableentry.typ of
absolutevarsym,
globalvarsym,
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;
{ derefed pointer }
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) then
result:=true
else
if report_errors then
CGMessagePos(tloadnode(hp).fileinfo,type_e_no_assign_to_const);
exit;
end;
result:=true;
exit;
end;
typedconstsym :
begin
if ttypedconstsym(tloadnode(hp).symtableentry).is_writable or
(valid_addr in opts) or
(valid_const in opts) then
result:=true
else
if report_errors then
CGMessagePos(hp.fileinfo,type_e_no_assign_to_const);
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.resulttype.def.deftype=formaldef) or
valid_for_assign(p,[valid_void,valid_const],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);
begin
{ Note: eq must be already valid, it will only be updated! }
case def_to.deftype of
formaldef :
begin
{ all types can be passed to a formaldef,
but it is not the prefered way }
eq:=te_convert_l2;
end;
orddef :
begin
{ allows conversion from word to integer and
byte to shortint, but only for TP7 compatibility }
if (m_tp7 in aktmodeswitches) and
(def_from.deftype=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).elementtype.def,tarraydef(def_to).elementtype.def) then
eq:=te_convert_l2
else
if equal_defs(def_from,tarraydef(def_to).elementtype.def) then
eq:=te_convert_l2;
end;
end;
pointerdef :
begin
{ an implicit pointer conversion is allowed }
if (def_from.deftype=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.deftype=objectdef) and
(
not(m_delphi in aktmodeswitches) or
(
(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.deftype=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.deftype 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.resulttype.def.deftype=stringdef) and
(tstringdef(def_to).string_typ=tstringdef(p.resulttype.def).string_typ) 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.resulttype.def) and
(is_shortstring(def_to) or is_ansistring(def_to))
) or
(
is_widechar(p.resulttype.def) and
is_widestring(def_to)
) then
eq:=te_equal
end;
setdef :
begin
{ set can also be a not yet converted array constructor }
if (p.resulttype.def.deftype=arraydef) and
is_array_constructor(p.resulttype.def) and
not is_variant_array(p.resulttype.def) then
eq:=te_equal;
end;
procvardef :
begin
{ in tp7 mode proc -> procvar is allowed }
if ((m_tp_procvar in aktmodeswitches) or
(m_mac_procvar in aktmodeswitches)) 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 aktmodeswitches) 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 aktlocalswitches) and
(nt in [addn,subn]));
end;
{****************************************************************************
TCallCandidates
****************************************************************************}
constructor tcallcandidates.create(sym:tprocsym;st:tsymtable;ppn:tnode;isprop,ignorevis : boolean);
var
j : integer;
pd : tprocdef;
hp : pcandidate;
found,
has_overload_directive : boolean;
topclassh : tobjectdef;
srsymtable : tsymtable;
srprocsym : tprocsym;
pt : tcallparanode;
checkstack : psymtablestackitem;
begin
if not assigned(sym) then
internalerror(200411015);
FProcSym:=sym;
FProcs:=nil;
FProccnt:=0;
FProcvisiblecnt:=0;
FParanode:=ppn;
FAllowVariant:=true;
{ determine length of parameter list }
pt:=tcallparanode(ppn);
FParalength:=0;
while assigned(pt) do
begin
inc(FParalength);
pt:=tcallparanode(pt.right);
end;
{ when the definition has overload directive set, we search for
overloaded definitions in the class, this only needs to be done once
for class entries as the tree keeps always the same }
if (not sym.overloadchecked) and
(sym.owner.symtabletype=objectsymtable) and
(po_overload in sym.first_procdef.procoptions) then
search_class_overloads(sym);
{ 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(st) and
(
(st.symtabletype=objectsymtable) or
((st.symtabletype=withsymtable) and
(st.defowner.deftype=objectdef))
) and
(st.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
st.defowner.owner.iscurrentunit then
topclassh:=tobjectdef(st.defowner)
else
begin
if assigned(current_procinfo) then
topclassh:=current_procinfo.procdef._class
else
topclassh:=nil;
end;
{ link all procedures which have the same # of parameters }
for j:=1 to sym.procdef_count do
begin
pd:=sym.procdef[j];
{ Is the procdef visible? This needs to be checked on
procdef level since a symbol can contain both private and
public declarations. But the check should not be done
when the callnode is generated by a property
inherited overrides invisible anonymous inherited (FK) }
if isprop or ignorevis or
(pd.owner.symtabletype<>objectsymtable) or
pd.is_visible_for_object(topclassh,nil) then
begin
{ we have at least one procedure that is visible }
inc(FProcvisiblecnt);
{ only when the # of parameter are supported by the
procedure }
if (FParalength>=pd.minparacount) and
((po_varargs in pd.procoptions) or { varargs }
(FParalength<=pd.maxparacount)) then
proc_add(pd);
end;
end;
{ remember if the procedure is declared with the overload directive,
it's information is still needed also after all procs are removed }
has_overload_directive:=(po_overload in sym.first_procdef.procoptions);
{ when the definition has overload directive set, we search for
overloaded 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 has_overload_directive and
(sym.owner.symtabletype<>objectsymtable) then
begin
srsymtable:=sym.owner;
checkstack:=symtablestack.stack;
while assigned(checkstack) and
(checkstack^.symtable<>srsymtable) do
checkstack:=checkstack^.next;
{ we've already processed the current symtable, start with
the next symtable in the stack }
if assigned(checkstack) then
checkstack:=checkstack^.next;
while assigned(checkstack) do
begin
srsymtable:=checkstack^.symtable;
if srsymtable.symtabletype in [localsymtable,staticsymtable,globalsymtable] then
begin
srprocsym:=tprocsym(srsymtable.speedsearch(sym.name,sym.speedvalue));
if assigned(srprocsym) and
(srprocsym.typ=procsym) then
begin
{ if this visible procedure doesn't have overload we can stop
searching }
if not(po_overload in srprocsym.first_procdef.procoptions) and
srprocsym.first_procdef.is_visible_for_object(topclassh,nil) then
break;
{ process all overloaded definitions }
for j:=1 to srprocsym.procdef_count do
begin
pd:=srprocsym.procdef[j];
{ only visible procedures need to be added }
if pd.is_visible_for_object(topclassh,nil) then
begin
{ only when the # of parameter are supported by the
procedure }
if (FParalength>=pd.minparacount) and
((po_varargs in pd.procoptions) or { varargs }
(FParalength<=pd.maxparacount)) then
begin
found:=false;
hp:=FProcs;
while assigned(hp) do
begin
{ Only compare visible parameters for the user }
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(pd);
end;
end;
end;
end;
end;
checkstack:=checkstack^.next;
end;
end;
end;
constructor tcallcandidates.create_operator(op:ttoken;ppn:tnode);
var
j : integer;
pd : tprocdef;
hp : pcandidate;
found : boolean;
srsymtable : tsymtable;
srprocsym : tprocsym;
pt : tcallparanode;
sv : cardinal;
checkstack : psymtablestackitem;
begin
FProcSym:=nil;
FProcs:=nil;
FProccnt:=0;
FProcvisiblecnt:=0;
FParanode:=ppn;
FAllowVariant:=false;
{ determine length of parameter list }
pt:=tcallparanode(ppn);
FParalength:=0;
while assigned(pt) do
begin
if pt.resulttype.def.deftype=variantdef then
FAllowVariant:=true;
inc(FParalength);
pt:=tcallparanode(pt.right);
end;
{ 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 }
sv:=getspeedvalue(overloaded_names[op]);
checkstack:=symtablestack.stack;
while assigned(checkstack) do
begin
srsymtable:=checkstack^.symtable;
if srsymtable.symtabletype in [localsymtable,staticsymtable,globalsymtable] then
begin
srprocsym:=tprocsym(srsymtable.speedsearch(overloaded_names[op],sv));
if assigned(srprocsym) and
(srprocsym.typ=procsym) then
begin
{ Store first procsym found }
if not assigned(FProcsym) then
FProcsym:=srprocsym;
{ process all overloaded definitions }
for j:=1 to srprocsym.procdef_count do
begin
pd:=srprocsym.procdef[j];
{ only when the # of parameter are supported by the
procedure }
if (FParalength>=pd.minparacount) and
(FParalength<=pd.maxparacount) then
begin
found:=false;
hp:=FProcs;
while assigned(hp) do
begin
{ Only compare visible parameters for the user }
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(pd);
end;
end;
end;
end;
checkstack:=checkstack^.next;
end;
end;
destructor tcallcandidates.destroy;
var
hpnext,
hp : pcandidate;
begin
hp:=FProcs;
while assigned(hp) do
begin
hpnext:=hp^.next;
dispose(hp);
hp:=hpnext;
end;
end;
function tcallcandidates.proc_add(pd:tprocdef):pcandidate;
var
defaultparacnt : integer;
begin
{ generate new candidate entry }
new(result);
fillchar(result^,sizeof(tcandidate),0);
result^.data:=pd;
result^.next:=FProcs;
FProcs:=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;
end;
procedure tcallcandidates.list(all:boolean);
var
hp : pcandidate;
begin
hp:=FProcs;
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.resulttype.def.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:=FProcs;
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)+
' 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 (vo_is_hidden_para in currpara.varoptions) then
Comment(lvl,' - '+currpara.vartype.def.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 : bestreal;
objdef : tobjectdef;
def_from,
def_to : tdef;
currpt,
pt : tcallparanode;
eq : tequaltype;
convtype : tconverttype;
pdtemp,
pdoper : tprocdef;
releasecurrpt : boolean;
cdoptions : tcompare_defs_options;
begin
cdoptions:=[cdo_check_operator];
if FAllowVariant then
include(cdoptions,cdo_allow_variant);
{ process all procs }
hp:=FProcs;
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.resulttype.def;
def_to:=currpara.vartype.def;
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 (def_to.deftype<>procvardef) and
(currpt.left.resulttype.def.deftype=procvardef) then
begin
releasecurrpt:=true;
currpt:=tcallparanode(pt.getcopy);
if maybe_call_procvar(currpt.left,true) then
begin
currpt.resulttype:=currpt.left.resulttype;
def_from:=currpt.left.resulttype.def;
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.deftype=procvardef) and
(currpt.left.nodetype=loadn) and
(currpt.left.resulttype.def.deftype=procdef) then
begin
pdtemp:=tprocsym(Tloadnode(currpt.left).symtableentry).search_procdef_byprocvardef(Tprocvardef(def_to));
if assigned(pdtemp) then
begin
tloadnode(currpt.left).procdef:=pdtemp;
currpt.left.resulttype.setdef(tloadnode(currpt.left).procdef);
currpt.resulttype:=currpt.left.resulttype;
def_from:=currpt.left.resulttype.def;
end;
end;
{ varargs are always equal, but not exact }
if (po_varargs in hp^.data.procoptions) and
(currparanr>hp^.data.minparacount) then
begin
eq:=te_equal;
end
else
{ same definition -> exact }
if (def_from=def_to) then
begin
eq:=te_exact;
end
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));
if (torddef(def_to).typ=u64bit) then
rth:=bestreal(qword(torddef(def_to).high))
else
rth:=bestreal(torddef(def_to).high);
if (torddef(def_from).typ=u64bit) then
rfh:=bestreal(qword(torddef(def_from).high))
else
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
hp^.ordinal_distance:=hp^.ordinal_distance+1.0;
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:=bestreal(4)
else
if is_double (def_to) then
rth:=bestreal(2)
else
rth:=bestreal(1);
if is_extended(def_from) then
rfh:=bestreal(4)
else
if is_double (def_from) then
rfh:=bestreal(2)
else
rfh:=bestreal(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.deftype=objectdef) and
(def_to.deftype=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
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.resulttype.def,currpara.vartype.def)
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_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 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 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;
is_better_candidate:=res;
end;
function tcallcandidates.choose_best(var bestpd:tabstractprocdef):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:=FProcs^.data;
if FProcs^.invalid then
cntpd:=0
else
cntpd:=1;
if assigned(FProcs^.next) then
begin
besthpstart:=FProcs;
hp:=FProcs^.next;
while assigned(hp) do
begin
res:=is_better_candidate(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:=FProcs;
{ 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.resulttype.def,wrongpara.vartype.def,pt.nodetype)<>te_incompatible) and
not valid_for_var(pt.left,true) then
CGMessagePos(pt.left.fileinfo,type_e_variable_id_expected)
else
CGMessagePos2(pt.left.fileinfo,parser_e_call_by_ref_without_typeconv,
FullTypeName(pt.left.resulttype.def,wrongpara.vartype.def),
FullTypeName(wrongpara.vartype.def,pt.left.resulttype.def))
end
else
CGMessagePos3(pt.left.fileinfo,type_e_wrong_parameter_type,tostr(hp^.wrongparanr),
FullTypeName(pt.left.resulttype.def,wrongpara.vartype.def),
FullTypeName(wrongpara.vartype.def,pt.left.resulttype.def));
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_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
{ 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.deftype in [enumdef,orddef,floatdef]) and
not is_boolean(destdef) and
assigned(source.resulttype.def) and
(source.resulttype.def.deftype in [enumdef,orddef,floatdef]) and
not is_boolean(source.resulttype.def) and
not is_constrealnode(source) then
begin
if (destdef.size < source.resulttype.def.size) then
begin
if (cs_check_range in aktlocalswitches) 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