{ 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,cmsgs,tokens, node,globtype,compinnr, symconst,symtype,symdef,symsym,symbase, pgentype; type Ttok2nodeRec=record tok : ttoken; nod : tnodetype; inr : tinlinenumber; op_overloading_supported : boolean; minargs : longint; maxargs : longint; end; Ttok2opRec=record tok : ttoken; managementoperator : tmanagementoperator; 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, cl6_count, coper_count : integer; { should be signed } ordinal_distance : double; invalid : boolean; {$ifndef DISABLE_FAST_OVERLOAD_PATCH} saved_validity : boolean; {$endif} wrongparanr : byte; end; tcallcandidates = class private FProcsym : tprocsym; FProcsymtable : tsymtable; FOperator : ttoken; FCandidateProcs : pcandidate; FIgnoredCandidateProcs: tfpobjectlist; FProcCnt : integer; FParaNode : tnode; FParaLength : smallint; FAllowVariant : boolean; procedure collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers,anoninherited:boolean;spezcontext:tspecializationcontext); procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall,explicitunit: boolean;spezcontext:tspecializationcontext); procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean;spezcontext:tspecializationcontext); procedure calc_distance(st_root:tsymtable;objcidcall: boolean); function proc_add(st:tsymtable;pd:tprocdef;objcidcall: boolean):pcandidate; function maybe_specialize(var pd:tprocdef;spezcontext:tspecializationcontext):boolean; public constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean;spezcontext:tspecializationcontext); 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, { variable is accessed in a different scope } ra_different_scope); tregableinfoflags = set of tregableinfoflag; const tok2nodes=27; tok2node:array[1..tok2nodes] of ttok2noderec=( (tok:_PLUS ;nod:addn;inr:in_none;op_overloading_supported:true;minargs:1;maxargs:2), { binary overloading supported } (tok:_MINUS ;nod:subn;inr:in_none;op_overloading_supported:true;minargs:1;maxargs:2), { binary and unary overloading supported } (tok:_STAR ;nod:muln;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_SLASH ;nod:slashn;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_EQ ;nod:equaln;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_GT ;nod:gtn;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_LT ;nod:ltn;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_GTE ;nod:gten;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_LTE ;nod:lten;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_SYMDIF ;nod:symdifn;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_STARSTAR ;nod:starstarn;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_OP_AS ;nod:asn;inr:in_none;op_overloading_supported:false;minargs:0;maxargs:0), { binary overloading NOT supported } (tok:_OP_IN ;nod:inn;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_OP_IS ;nod:isn;inr:in_none;op_overloading_supported:false;minargs:0;maxargs:0), { binary overloading NOT supported } (tok:_OP_OR ;nod:orn;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_OP_AND ;nod:andn;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_OP_DIV ;nod:divn;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_OP_NOT ;nod:notn;inr:in_none;op_overloading_supported:true;minargs:1;maxargs:1), { unary overloading supported } (tok:_OP_MOD ;nod:modn;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_OP_SHL ;nod:shln;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_OP_SHR ;nod:shrn;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_OP_XOR ;nod:xorn;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_ASSIGNMENT ;nod:assignn;inr:in_none;op_overloading_supported:true;minargs:1;maxargs:1), { unary overloading supported } (tok:_OP_EXPLICIT;nod:assignn;inr:in_none;op_overloading_supported:true;minargs:1;maxargs:1), { unary overloading supported } (tok:_NE ;nod:unequaln;inr:in_none;op_overloading_supported:true;minargs:2;maxargs:2), { binary overloading supported } (tok:_OP_INC ;nod:inlinen;inr:in_inc_x;op_overloading_supported:true;minargs:1;maxargs:1), { unary overloading supported } (tok:_OP_DEC ;nod:inlinen;inr:in_dec_x;op_overloading_supported:true;minargs:1;maxargs:1) { unary overloading supported } ); tok2ops=4; tok2op: array[1..tok2ops] of ttok2oprec=( (tok:_OP_INITIALIZE; managementoperator: mop_initialize), (tok:_OP_FINALIZE ; managementoperator: mop_finalize), (tok:_OP_ADDREF ; managementoperator: mop_addref), (tok:_OP_COPY ; managementoperator: mop_copy) ); function node2opstr(nt:tnodetype):string; function token2managementoperator(optoken:ttoken):tmanagementoperator; { check operator args and result type } type toverload_check_flag = ( ocf_check_non_overloadable, { also check operators that are (currently) considered as not overloadable (e.g. the "+" operator for dynamic arrays if modeswitch arrayoperators is active) } ocf_check_only { only check whether the operator is overloaded, but don't modify the passed in node (return true if the operator is overloaded, false otherwise) } ); toverload_check_flags = set of toverload_check_flag; 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;ocf:toverload_check_flags) : boolean; function isbinaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; { Register Allocation } procedure make_not_regable(p : tnode; how: tregableinfoflags); { procvar handling } function is_proc2procvar_load(p:tnode;out realprocdef:tprocdef):boolean; { returns whether a node represents a load of the function result node via the function name (so it could also be a recursive call to the function in case there or no parameters, or the function could be passed as procvar } function is_ambiguous_funcret_load(p: tnode; out owningprocdef: tprocdef): 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,vsf_use_hint_for_string_result); 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_constref(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_ranges(const location: tfileposinfo; source: tnode; destdef: tdef); { returns whether the def may be used in the Default() intrinsic; static arrays, records and objects are checked recursively } function is_valid_for_default(def:tdef):boolean; procedure UninitializedVariableMessage(pos : tfileposinfo;warning,local,managed : boolean;name : TMsgStr); implementation uses systems,constexp,globals, cutils,verbose, symtable,symutil, defutil,defcmp, nbas,ncnv,nld,nmem,ncal,nmat,ninl,nutils,procinfo, pgenutil ; type TValidAssign=(Valid_Property,Valid_Void,Valid_Const,Valid_Addr,Valid_Packed,Valid_Range); TValidAssigns=set of TValidAssign; { keep these two in sync! } const non_commutative_op_tokens=[_OP_SHL,_OP_SHR,_OP_DIV,_OP_MOD,_STARSTAR,_SLASH,_MINUS]; non_commutative_op_nodes=[shln,shrn,divn,modn,starstarn,slashn,subn]; function node2opstr(nt:tnodetype):string; var i : integer; begin result:=''; for i:=1 to tok2nodes do if tok2node[i].nod=nt then begin result:=tokeninfo^[tok2node[i].tok].str; break; end; end; function token2managementoperator(optoken:ttoken):tmanagementoperator; var i : integer; begin result:=mop_none; for i:=1 to tok2ops do if tok2op[i].tok=optoken then begin result:=tok2op[i].managementoperator; 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; const identity_operators=[equaln,unequaln]; order_theoretic_operators=identity_operators+[ltn,lten,gtn,gten]; arithmetic_operators=[addn,subn,muln,divn,modn]; rational_operators=[addn,subn,muln,slashn]; numerical_operators=arithmetic_operators+[slashn]; pointer_arithmetic_operators=[addn,subn]; logical_operators=[andn,orn,xorn]; bit_manipulation_operators=logical_operators+[shln,shrn]; set_set_operators=identity_operators+[addn,subn,muln,symdifn]+ order_theoretic_operators; element_set_operators=[inn]; string_comparison_operators=order_theoretic_operators; string_manipulation_operators=[addn]; string_operators = string_comparison_operators+string_manipulation_operators; begin internal_check:=true; { Reject the cases permitted by the default interpretation (DI). } case ld.typ of formaldef, recorddef, variantdef : begin allowed:=true; end; enumdef: begin allowed:=not ( ( is_set(rd) and (treetyp in element_set_operators) ) or ( is_enum(rd) and (treetyp in (order_theoretic_operators+[addn, subn])) ) or ( { for enum definitions, see webtbs/tw22860.pp } is_integer(rd) and (treetyp in (order_theoretic_operators+bit_manipulation_operators+arithmetic_operators)) ) ); end; setdef: begin allowed:=not ( ( is_set(rd) and (treetyp in (set_set_operators+identity_operators)) ) or ( { This clause is a hack but it’s due to a hack somewhere else---while set + element is not permitted by DI, it seems to be used when a set is constructed inline } (rd.typ in [enumdef,orddef]) and (treetyp=addn) ) ); end; orddef, floatdef: begin allowed:=not ( ( (rd.typ in [orddef,floatdef]) and (treetyp in order_theoretic_operators) ) or ( (m_mac in current_settings.modeswitches) and is_stringlike(rd) and (ld.typ=orddef) and (treetyp in string_comparison_operators)) or { c.f. $(source)\tests\tmacpas5.pp } ( (rd.typ=setdef) and (ld.typ=orddef) and (treetyp in element_set_operators) ) { This clause may be too restrictive---not all types under orddef have a corresponding set type; despite this the restriction should be very unlikely to become a practical obstacle, and can be relaxed by simply adding an extra check on TOrdDef(rd).ordtype } ); { Note that Currency can be under either orddef or floatdef; when it’s under floatdef, is_currency() implies is_float(); when it’s under orddef, is_currency() does NOT imply is_integer(). } if allowed then begin if is_anychar(ld) then allowed:=not ( is_stringlike(rd) and (treetyp in string_operators) ) else if is_boolean(ld) then allowed:=not ( is_boolean(rd) and (treetyp in logical_operators) ) else if is_integer(ld) or ( (ld.typ=orddef) and is_currency(ld) { Here ld is Currency but behaves like an integer } ) then allowed:=not ( ( ( is_integer(rd) or ( (rd.typ=orddef) and is_currency(rd) ) ) and (treetyp in (bit_manipulation_operators+numerical_operators)) ) or ( is_fpu(rd) and (treetyp in rational_operators) ) or ( { When an integer type is used as the first operand in pointer arithmetic, DI doesn’t accept minus as the operator (Currency can’t be used in pointer arithmetic even if it’s under orddef) } is_integer(ld) and (rd.typ=pointerdef) and (treetyp in pointer_arithmetic_operators-[subn]) ) ) else { is_fpu(ld) = True } allowed:=not ( ( is_fpu(rd) or is_integer(rd) or is_currency(rd) ) and (treetyp in rational_operators) ); end; end; procvardef : begin if (rd.typ in [pointerdef,procdef,procvardef]) then begin allowed:=false; exit; end; allowed:=true; end; pointerdef : begin { DI permits pointer arithmetic for pointer + pointer, pointer - integer, pointer - pointer, but not for pointer + pointer. The last case is only valid in DI when both sides are stringlike. } if is_stringlike(ld) then if is_stringlike(rd) then { DI in this case permits string operations and pointer arithmetic. } allowed:=not (treetyp in (string_operators+pointer_arithmetic_operators)) else if rd.typ = pointerdef then { DI in this case permits minus for pointer arithmetic and order-theoretic operators for pointer comparison. } allowed:=not ( treetyp in ( pointer_arithmetic_operators-[addn]+ order_theoretic_operators ) ) else if is_integer(rd) then { DI in this case permits pointer arithmetic. } allowed:=not (treetyp in pointer_arithmetic_operators) else allowed:=true else allowed:=not ( ( is_integer(rd) and (treetyp in pointer_arithmetic_operators) ) or ( (rd.typ=pointerdef) and ( treetyp in ( pointer_arithmetic_operators-[addn]+ order_theoretic_operators ) ) ) or ( (lt=niln) and (rd.typ in [procvardef,procdef,classrefdef]) and (treetyp in identity_operators) ) or ( is_implicit_pointer_object_type(rd) and (treetyp in identity_operators) ) ); 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; if is_stringlike(ld) and ( ( ( is_stringlike(rd) or (rt = niln) ) and (treetyp in string_operators) ) or ( is_integer(rd) and (treetyp in pointer_arithmetic_operators) ) or ( ( is_pchar(rd) or is_pwidechar(rd)) and (treetyp in pointer_arithmetic_operators) and (tpointerdef(rd).pointeddef=tarraydef(ld).elementdef ) ) ) then begin allowed:=false; exit; end; { dynamic array compare with niln } if is_dynamic_array(ld) and (treetyp in identity_operators) then if is_dynamic_array(rd) or (rt=niln) then begin allowed:=false; exit; end; { + is handled by the compiler } if (m_array_operators in current_settings.modeswitches) and (treetyp=addn) and (is_dynamic_array(ld) or is_dynamic_array(rd)) then begin allowed:=false; exit; end; allowed:=true; end; objectdef : begin { <> and = are defined for implicit pointer object types } allowed:=not ( is_implicit_pointer_object_type(ld) and ( ( is_implicit_pointer_object_type(rd) or (rd.typ=pointerdef) or (rt=niln) or ((ld=java_jlstring) and is_stringlike(rd)) ) ) and (treetyp in identity_operators) ); end; stringdef : begin allowed:=not ( is_stringlike(rd) and (treetyp in string_operators) ); end; else internal_check:=false; end; end; begin { power ** is always possible } result:=treetyp=starstarn; if not result then begin if not internal_check(treetyp,ld,lt,rd,rt,result) and not (treetyp in non_commutative_op_nodes) then internal_check(treetyp,rd,rt,ld,lt,result) end; end; function isunaryoperatoroverloadable(treetyp:tnodetype;inlinenumber:tinlinenumber;ld:tdef) : boolean; begin result:=false; case treetyp of subn, addn, unaryminusn, unaryplusn, inlinen: begin { only Inc, Dec inline functions are supported for now, so skip check inlinenumber } 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 = orddef 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; else ; end; end; function isoperatoracceptable(pf : tprocdef; optoken : ttoken) : boolean; var ld,rd : tdef; i : longint; eq : tequaltype; conv : tconverttype; cdo : tcompare_defs_options; pd : tprocdef; oldcount, count: longint; sym : tsym; parasym : tparavarsym absolute sym; begin result:=false; count := pf.parast.SymList.count; oldcount:=count; while count > 0 do begin sym:=tsym(pf.parast.SymList[count-1]); if sym.typ<>paravarsym then begin dec(count); end else 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 in [_ASSIGNMENT,_OP_EXPLICIT] then begin cdo:=[]; if optoken=_OP_EXPLICIT then include(cdo,cdo_explicit); eq:=compare_defs_ext(ld,pf.returndef,nothingn,conv,pd,cdo); result:= (eq=te_exact) or (eq=te_incompatible); end else { enumerator is a special case too } if optoken=_OP_ENUMERATOR then begin result:= is_class_or_interface_or_object(pf.returndef) or is_record(pf.returndef); if result then begin if not assigned(tabstractrecorddef(pf.returndef).search_enumerator_move) then begin Message1(sym_e_no_enumerator_move, pf.returndef.typename); result:=false; end; if not assigned(tabstractrecorddef(pf.returndef).search_enumerator_current) then begin Message1(sym_e_no_enumerator_current,pf.returndef.typename); result:=false; end; end; end else begin for i:=1 to tok2nodes do if tok2node[i].tok=optoken then begin result:= tok2node[i].op_overloading_supported and (tok2node[i].minargs<=1) and (tok2node[i].maxargs>=1) and isunaryoperatoroverloadable(tok2node[i].nod,tok2node[i].inr,ld); break; end; { Inc, Dec operators are valid if only result type is the same as argument type } if result and (optoken in [_OP_INC,_OP_DEC]) then result:=pf.returndef=ld; 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 (tok2node[i].minargs<=2) and (tok2node[i].maxargs>=2) and isbinaryoperatoroverloadable(tok2node[i].nod,ld,nothingn,rd,nothingn); break; end; end; end; end; function isunaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; var ld : tdef; optoken : ttoken; operpd : tprocdef; ppn : tcallparanode; candidates : tcallcandidates; cand_cnt : integer; inlinenumber: tinlinenumber; begin result:=false; operpd:=nil; { load easier access variables } ld:=tunarynode(t).left.resultdef; { if we are dealing with inline function then get the function } if t.nodetype=inlinen then inlinenumber:=tinlinenode(t).inlinenumber else inlinenumber:=in_none; if not (ocf_check_non_overloadable in ocf) and not isunaryoperatoroverloadable(t.nodetype,inlinenumber,ld) then exit; { operator overload is possible } result:=not (ocf_check_only in ocf); optoken:=NOTOKEN; case t.nodetype of notn: optoken:=_OP_NOT; unaryminusn: optoken:=_MINUS; unaryplusn: optoken:=_PLUS; inlinen: case inlinenumber of in_inc_x: optoken:=_OP_INC; in_dec_x: optoken:=_OP_DEC; else ; end; else ; end; if (optoken=NOTOKEN) then begin if not (ocf_check_only in ocf) then begin CGMessage(parser_e_operator_not_overloaded); t:=cnothingnode.create; end; exit; end; { generate parameter nodes } { for inline nodes just copy existent callparanode } if (t.nodetype=inlinen) and (tinlinenode(t).left.nodetype=callparan) then ppn:=tcallparanode(tinlinenode(t).left.getcopy) else begin ppn:=ccallparanode.create(tunarynode(t).left.getcopy,nil); ppn.get_paratype; end; candidates:=tcallcandidates.create_operator(optoken,ppn); { stop when there are no operators found } if candidates.count=0 then begin candidates.free; ppn.free; if not (ocf_check_only in ocf) then begin CGMessage2(parser_e_operator_not_overloaded_2,ld.typename,arraytokeninfo[optoken].str); t:=cnothingnode.create; end; 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 candidates.free; ppn.free; if not (ocf_check_only in ocf) then begin CGMessage2(parser_e_operator_not_overloaded_2,ld.typename,arraytokeninfo[optoken].str); t:=cnothingnode.create; end; exit; end; { Multiple candidates left? } if (cand_cnt>1) and not (ocf_check_only in ocf) 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; if ocf_check_only in ocf then begin ppn.free; result:=true; exit; end; addsymref(operpd.procsym,operpd); { the nil as symtable signs firstcalln that this is an overloaded operator } t:=ccallnode.create(ppn,Tprocsym(operpd.procsym),nil,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;ocf:toverload_check_flags) : boolean; var rd,ld : tdef; optoken : ttoken; operpd : tprocdef; ht : tnode; ppn : tcallparanode; cand_cnt : integer; function search_operator(optoken:ttoken;generror:boolean): integer; var candidates : tcallcandidates; begin { 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 non_commutative_op_tokens) then begin candidates.free; reverseparameters(ppn); { reverse compare operators } case optoken of _LT: optoken:=_GTE; _GT: optoken:=_LTE; _LTE: optoken:=_GT; _GTE: optoken:=_LT; else ; end; candidates:=tcallcandidates.create_operator(optoken,ppn); end; { stop when there are no operators found } result:=candidates.count; if (result=0) and generror then begin CGMessage(parser_e_operator_not_overloaded); candidates.free; ppn.free; ppn:=nil; exit; end; if (result>0) then begin { Retrieve information about the candidates } candidates.get_information; {$ifdef EXTDEBUG} { Display info when multiple candidates are found } candidates.dump_info(V_Debug); {$endif EXTDEBUG} result:=candidates.choose_best(tabstractprocdef(operpd),false); end; { exit when no overloads are found } if (result=0) and generror then begin CGMessage3(parser_e_operator_not_overloaded_3,ld.typename,arraytokeninfo[optoken].str,rd.typename); candidates.free; ppn.free; ppn:=nil; exit; end; { Multiple candidates left? } if result>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; end; begin isbinaryoverloaded:=false; operpd:=nil; ppn:=nil; { load easier access variables } ld:=tbinarynode(t).left.resultdef; rd:=tbinarynode(t).right.resultdef; if not (ocf_check_non_overloadable in ocf) and not isbinaryoperatoroverloadable(t.nodetype,ld,tbinarynode(t).left.nodetype,rd,tbinarynode(t).right.nodetype) then exit; { operator overload is possible } { if we only check for the existance of the overload, then we assume that it is not overloaded } result:=not (ocf_check_only in ocf); case t.nodetype of equaln: optoken:=_EQ; unequaln: optoken:=_NE; 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; inn : optoken:=_OP_IN; else begin if not (ocf_check_only in ocf) then begin CGMessage(parser_e_operator_not_overloaded); t:=cnothingnode.create; end; exit; end; end; cand_cnt:=search_operator(optoken,(optoken<>_NE) and not (ocf_check_only in ocf)); { no operator found for "<>" then search for "=" operator } if (cand_cnt=0) and (optoken=_NE) and not (ocf_check_only in ocf) then begin ppn.free; ppn:=nil; operpd:=nil; optoken:=_EQ; cand_cnt:=search_operator(optoken,true); end; if (cand_cnt=0) then begin ppn.free; if not (ocf_check_only in ocf) then t:=cnothingnode.create; exit; end; if ocf_check_only in ocf then begin ppn.free; result:=true; exit; end; addsymref(operpd.procsym,operpd); { the nil as symtable signs firstcalln that this is an overloaded operator } ht:=ccallnode.create(ppn,Tprocsym(operpd.procsym),nil,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 we found "=" operator for "<>" expression then use it together with "not" } if (t.nodetype=unequaln) and (optoken=_EQ) 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); begin if ra_addr_taken in how then include(p.flags,nf_address_taken); repeat case p.nodetype of subscriptn: begin records_only:=true; p:=tsubscriptnode(p).left; end; vecn: begin { if there's an implicit dereference, we can stop (just like when there is an actual derefn) } if ((tvecnode(p).left.resultdef.typ=arraydef) and not is_special_array(tvecnode(p).left.resultdef)) or ((tvecnode(p).left.resultdef.typ=stringdef) and (tstringdef(tvecnode(p).left.resultdef).stringtype in [st_shortstring,st_longstring])) then p:=tvecnode(p).left else break; end; typeconvn : begin { implicit dereference -> stop } if (ttypeconvnode(p).convtype=tc_pointer_2_array) then break; 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 (ra_different_scope in how) then tabstractvarsym(tloadnode(p).symtableentry).different_scope:=true; if (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 ttemprefnode(p).includetempflag(ti_addr_taken); if (ti_may_be_in_reg in ttemprefnode(p).tempflags) and ((not records_only) or (ttemprefnode(p).tempinfo^.typedef.typ = recorddef)) then ttemprefnode(p).excludetempflag(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_proc2procvar_load(p:tnode;out realprocdef:tprocdef):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); if result then realprocdef:=tprocdef(ttypeconvnode(p).left.resultdef); end; function is_ambiguous_funcret_load(p: tnode; out owningprocdef: tprocdef): boolean; begin result:=false; { the funcret is an absolutevarsym, which gets converted into a type conversion node of the loadnode of the actual function result. Its resulttype is obviously the same as that of the real function result } if (p.nodetype=typeconvn) and (p.resultdef=ttypeconvnode(p).left.resultdef) then p:=ttypeconvnode(p).left; if (p.nodetype=loadn) and (tloadnode(p).symtableentry.typ in [absolutevarsym,localvarsym,paravarsym]) and ([vo_is_funcret,vo_is_result] * tabstractvarsym(tloadnode(p).symtableentry).varoptions = [vo_is_funcret]) then begin owningprocdef:=tprocdef(tloadnode(p).symtableentry.owner.defowner); result:=true; end; end; { local routines can't be assigned to procvars } procedure test_local_to_procvar(from_def:tprocvardef;to_def:tdef); begin if not(m_nested_procvars in current_settings.modeswitches) and (from_def.parast.symtablelevel>normal_function_level) and (to_def.typ=procvardef) then CGMessage(type_e_cannot_local_proc_to_procvar); end; procedure UninitializedVariableMessage(pos : tfileposinfo;warning,local,managed : boolean;name : TMsgStr); const msg : array[false..true,false..true,false..true] of dword = ( ( (sym_h_uninitialized_variable,sym_h_uninitialized_managed_variable), (sym_h_uninitialized_local_variable,sym_h_uninitialized_managed_local_variable) ), ( (sym_w_uninitialized_variable,sym_w_uninitialized_managed_variable), (sym_w_uninitialized_local_variable,sym_w_uninitialized_managed_local_variable) ) ); begin CGMessagePos1(pos,msg[warning,local,managed],name); 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 : begin include(varstateflags,vsf_must_be_valid); { when a pointer is used for array access, the pointer itself is read and never written } newstate := vs_read; end; else ; end; p:=tunarynode(p).left; end; subscriptn : begin if is_implicit_pointer_object_type(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]); { dyn. arrays and dyn. strings are read } if is_implicit_array_pointer(tunarynode(p).left.resultdef) then newstate:=vs_read; 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 { the methodpointer/framepointer is read } if assigned(tunarynode(p).left) then set_varstate(tunarynode(p).left,vs_read,[vsf_must_be_valid]); if (tloadnode(p).symtableentry.typ in [localvarsym,paravarsym,staticvarsym]) then begin hsym:=tabstractvarsym(tloadnode(p).symtableentry); { this check requires proper data flow analysis... } (* if (hsym.varspez=vs_final) and (hsym.varstate in [vs_written,vs_readwritten]) and (newstate in [vs_written,vs_readwritten]) then CGMessagePos1(p.fileinfo,sym_e_final_write_once); *) 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(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 vsf_use_hints in varstateflags then include(tloadnode(p).loadnodeflags,loadnf_only_uninitialized_hint); if not(cs_opt_nodedfa in current_settings.optimizerswitches) then begin if (vo_is_funcret in hsym.varoptions) then begin { An uninitialized function Result of a managed type needs special handling. When passing it as a var parameter a warning need to be emitted, since a user may expect Result to be empty (nil) by default as it happens with local vars of a managed type. But this is not true for Result and may lead to serious issues. The only exception is SetLength(Result, ?) for a string Result. A user always expects undefined contents of the string after calling SetLength(). In such case a hint need to be emitted. } if is_managed_type(hsym.vardef) then if not ( is_string(hsym.vardef) and (vsf_use_hint_for_string_result in varstateflags) ) then exclude(varstateflags,vsf_use_hints); if vsf_use_hints in varstateflags then begin if is_managed_type(hsym.vardef) then CGMessagePos(p.fileinfo,sym_h_managed_function_result_uninitialized) else CGMessagePos(p.fileinfo,sym_h_function_result_uninitialized); end else begin if is_managed_type(hsym.vardef) then CGMessagePos(p.fileinfo,sym_w_managed_function_result_uninitialized) else CGMessagePos(p.fileinfo,sym_w_function_result_uninitialized); end; end else begin UninitializedVariableMessage(p.fileinfo, { on the JVM, an uninitialized var-parameter is just as fatal as a nil pointer dereference } not((vsf_use_hints in varstateflags) and not(target_info.system in systems_jvm)), tloadnode(p).symtable.symtabletype=localsymtable, is_managed_type(tloadnode(p).resultdef), 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); else ; end; break; end; addrn: break; 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 typeconvs: tfpobjectlist; hp2, hp : tnode; gotstring, gotsubscript, gotrecord, gotvec, gottypeconv : boolean; fromdef, todef : tdef; errmsg, temp : longint; function constaccessok(vs: tabstractvarsym): boolean; begin result:=false; { allow p^:= constructions with p is const parameter } if (Valid_Const in opts) or ((hp.nodetype=loadn) and (loadnf_isinternal_ignoreconst in tloadnode(hp).loadnodeflags)) then result:=true { final (class) fields can only be initialised in the (class) constructors of class in which they have been declared (not in descendent constructors) } else if vs.varspez=vs_final then begin if (current_procinfo.procdef.owner=vs.owner) then if vs.typ=staticvarsym then result:=current_procinfo.procdef.proctypeoption=potype_class_constructor else result:=current_procinfo.procdef.proctypeoption=potype_constructor; if not result and report_errors then CGMessagePos(hp.fileinfo,type_e_invalid_final_assignment); end else if report_errors then CGMessagePos(hp.fileinfo,type_e_no_assign_to_const); end; procedure mayberesettypeconvs; var i: longint; begin if assigned(typeconvs) then begin if not report_errors and not result then for i:=0 to typeconvs.Count-1 do ttypeconvnode(typeconvs[i]).assignment_side:=false; typeconvs.free; end; end; 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; gotrecord:=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; typeconvs:=nil; 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 recorddef : gotrecord:=true; stringdef : gotstring:=true; else ; 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 ( { 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) and not(nf_no_lvalue in hp.flags) ) 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 and a subscription or with is found 3. if the address is needed of a field (subscriptn, vecn) } if (gotstring and gotvec) or ( (Valid_Addr in opts) and (hp.nodetype in [subscriptn,vecn]) ) then result:=true else if report_errors then CGMessagePos(hp.fileinfo,errmsg); end; mayberesettypeconvs; exit; end; case hp.nodetype of temprefn : begin valid_for_assign := not(ti_readonly in ttemprefnode(hp).tempflags); mayberesettypeconvs; exit; end; derefn : begin { dereference -> always valid } valid_for_assign:=true; mayberesettypeconvs; exit; 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; { typeconversions on the assignment side must keep left.location the same } if not((target_info.system in systems_jvm) and (gotsubscript or gotvec)) then begin ttypeconvnode(hp).assignment_side:=true; if not assigned(typeconvs) then typeconvs:=tfpobjectlist.create(false); typeconvs.add(hp); end; { in managed VMs, you cannot typecast formaldef when assigning to it, see http://hallvards.blogspot.com/2007/10/dn4dp24-net-vs-win32-untyped-parameters.html } if (target_info.system in systems_managed_vm) and (fromdef.typ=formaldef) then begin if report_errors then CGMessagePos(hp.fileinfo,type_e_no_managed_formal_assign_typecast); mayberesettypeconvs; exit; end else if not((nf_absolute in ttypeconvnode(hp).flags) or ttypeconvnode(hp).target_specific_general_typeconv or ((nf_explicit in hp.flags) and ttypeconvnode(hp).target_specific_explicit_typeconv) 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 (def_is_related(fromdef,todef))) then begin if (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 array conversion is done then we need to see it as a deref, because a ^ is then not required anymore } if ttypeconvnode(hp).convtype=tc_pointer_2_array then begin valid_for_assign:=true; mayberesettypeconvs; exit end; end; else ; end; hp:=ttypeconvnode(hp).left; end; vecn : begin if (tvecnode(hp).right.nodetype=rangen) and not(valid_range in opts) then begin if report_errors then CGMessagePos(tvecnode(hp).right.fileinfo,parser_e_illegal_expression); mayberesettypeconvs; exit; end; 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); mayberesettypeconvs; exit; end; gotvec:=true; { accesses to dyn. arrays override read only access in delphi -- now also in FPC, because the elements of a dynamic array returned by a function can also be changed, or you can assign the dynamic array to a variable and then change its elements anyway } if is_dynamic_array(tunarynode(hp).left.resultdef) then begin result:=true; mayberesettypeconvs; exit; end; 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 gotvec) then begin if report_errors then CGMessagePos(hp.fileinfo,errmsg); mayberesettypeconvs; 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); mayberesettypeconvs; exit; end; { check for final fields } if (tsubscriptnode(hp).vs.varspez=vs_final) and not constaccessok(tsubscriptnode(hp).vs) then begin mayberesettypeconvs; exit; end; { if we assign something to a field of a record that is not regable, then then the record can't be kept in a regvar, because we will force the record into memory for this subscript operation (to a temp location, so the assignment will happen to the temp and be lost) } if not gotsubscript and not gotvec and not tstoreddef(hp.resultdef).is_intregable then make_not_regable(hp,[ra_addr_regable]); 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); mayberesettypeconvs; exit; end; { implicit pointer object types result in dereferencing } hp:=tsubscriptnode(hp).left; if is_implicit_pointer_object_type(hp.resultdef) or (hp.resultdef.typ=classrefdef) then begin valid_for_assign:=true; mayberesettypeconvs; exit end; end; muln, divn, andn, xorn, orn, notn, subn, addn : begin { 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); mayberesettypeconvs; exit; end; niln, pointerconstn : begin if report_errors then CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr); mayberesettypeconvs; exit; end; ordconstn, realconstn : begin { these constants will be passed by value } if report_errors then CGMessagePos(hp.fileinfo,type_e_variable_id_expected); mayberesettypeconvs; exit; end; arrayconstructorn, 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); mayberesettypeconvs; exit; end; addrn : begin if report_errors then CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr); mayberesettypeconvs; exit; end; blockn, calln : begin if (hp.nodetype=calln) or (nf_no_lvalue in hp.flags) then begin { 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); mayberesettypeconvs; exit; end else 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); mayberesettypeconvs; exit; end; end; end; inlinen : begin if ((valid_const in opts) and (tinlinenode(hp).inlinenumber in [in_typeof_x])) or (tinlinenode(hp).inlinenumber in [in_unaligned_x,in_aligned_x]) then result:=true else if report_errors then CGMessagePos(hp.fileinfo,type_e_variable_id_expected); mayberesettypeconvs; exit; end; nothingn : begin { generics can generate nothing nodes, just allow everything } if df_generic in current_procinfo.procdef.defoptions then result:=true else if report_errors then CGMessagePos(hp.fileinfo,type_e_variable_id_expected); mayberesettypeconvs; exit; end; loadn : begin case tloadnode(hp).symtableentry.typ of absolutevarsym, staticvarsym, localvarsym, paravarsym : begin { loop counter? } if not(Valid_Const in opts) and (vo_is_loop_counter in tabstractvarsym(tloadnode(hp).symtableentry).varoptions) then begin if report_errors then CGMessage1(parser_e_illegal_assignment_to_count_var,tloadnode(hp).symtableentry.realname); mayberesettypeconvs; exit; end; { read-only variable? } if (tabstractvarsym(tloadnode(hp).symtableentry).varspez in [vs_const,vs_constref,vs_final]) then begin result:=constaccessok(tabstractvarsym(tloadnode(hp).symtableentry)); mayberesettypeconvs; exit; end; result:=true; mayberesettypeconvs; 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); mayberesettypeconvs; 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); mayberesettypeconvs; 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); mayberesettypeconvs; exit; end; else begin if report_errors then CGMessagePos(hp.fileinfo,type_e_variable_id_expected); mayberesettypeconvs; exit; end; end; end; else begin if report_errors then CGMessagePos(hp.fileinfo,type_e_variable_id_expected); mayberesettypeconvs; exit; end; end; end; mayberesettypeconvs; end; function valid_for_var(p:tnode; report_errors: boolean):boolean; begin valid_for_var:=valid_for_assign(p,[valid_range],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,valid_range],report_errors); end; function valid_for_formal_constref(p : tnode; report_errors: boolean) : boolean; begin valid_for_formal_constref:=(p.resultdef.typ=formaldef) or valid_for_assign(p,[valid_void,valid_range],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,valid_range],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_l6 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_l3; 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 (def_is_related(tobjectdef(def_from),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; else ; end; end; procedure para_allowed(var eq:tequaltype;p:tcallparanode;def_to:tdef); var acn: tarrayconstructornode; realprocdef: tprocdef; tmpeq: tequaltype; begin { Note: eq must be already valid, it will only be updated! } case def_to.typ of 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) and (tstringdef(def_to).encoding=tstringdef(p.resultdef).encoding) then eq:=te_equal end; formaldef, 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 tmpeq:=te_incompatible; { in tp/macpas 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) then tmpeq:=proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def_to),false); if (tmpeq=te_incompatible) and (m_nested_procvars in current_settings.modeswitches) and is_proc2procvar_load(p.left,realprocdef) then tmpeq:=proc_to_procvar_equal(realprocdef,tprocvardef(def_to),false); if (tmpeq=te_incompatible) and (m_mac in current_settings.modeswitches) and is_ambiguous_funcret_load(p.left,realprocdef) then tmpeq:=proc_to_procvar_equal(realprocdef,tprocvardef(def_to),false); if tmpeq<>te_incompatible then eq:=tmpeq; end; arraydef : begin { an arrayconstructor of proccalls may have to be converted to an array of procvars } if ((m_tp_procvar in current_settings.modeswitches) or (m_mac_procvar in current_settings.modeswitches)) and (tarraydef(def_to).elementdef.typ=procvardef) and is_array_constructor(p.resultdef) and not is_variant_array(p.resultdef) then begin acn:=tarrayconstructornode(p.left); if assigned(acn.left) then begin eq:=te_exact; while assigned(acn) and (eq<>te_incompatible) do begin if (acn.left.nodetype=calln) then tmpeq:=proc_to_procvar_equal(tprocdef(tcallnode(acn.left).procdefinition),tprocvardef(tarraydef(def_to).elementdef),false) else tmpeq:=compare_defs(acn.left.resultdef,tarraydef(def_to).elementdef,acn.left.nodetype); if tmpeq