htypechk.pas 104 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. This unit exports some help routines for the type checking
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit htypechk;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. cclasses,tokens,cpuinfo,
  22. node,globtype,
  23. symconst,symtype,symdef,symsym,symbase;
  24. type
  25. Ttok2nodeRec=record
  26. tok : ttoken;
  27. nod : tnodetype;
  28. op_overloading_supported : boolean;
  29. end;
  30. pcandidate = ^tcandidate;
  31. tcandidate = record
  32. next : pcandidate;
  33. data : tprocdef;
  34. wrongparaidx,
  35. firstparaidx : integer;
  36. exact_count,
  37. equal_count,
  38. cl1_count,
  39. cl2_count,
  40. cl3_count,
  41. cl4_count,
  42. cl5_count,
  43. coper_count : integer; { should be signed }
  44. ordinal_distance : double;
  45. invalid : boolean;
  46. wrongparanr : byte;
  47. end;
  48. tcallcandidates = class
  49. private
  50. FProcsym : tprocsym;
  51. FProcsymtable : tsymtable;
  52. FOperator : ttoken;
  53. FCandidateProcs : pcandidate;
  54. FProcCnt : integer;
  55. FParaNode : tnode;
  56. FParaLength : smallint;
  57. FAllowVariant : boolean;
  58. procedure collect_overloads_in_class(ProcdefOverloadList:TFPObjectList);
  59. procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall: boolean);
  60. procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall:boolean);
  61. function proc_add(ps:tprocsym;pd:tprocdef;objcidcall: boolean):pcandidate;
  62. public
  63. constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall:boolean);
  64. constructor create_operator(op:ttoken;ppn:tnode);
  65. destructor destroy;override;
  66. procedure list(all:boolean);
  67. {$ifdef EXTDEBUG}
  68. procedure dump_info(lvl:longint);
  69. {$endif EXTDEBUG}
  70. procedure get_information;
  71. function choose_best(var bestpd:tabstractprocdef; singlevariant: boolean):integer;
  72. procedure find_wrong_para;
  73. property Count:integer read FProcCnt;
  74. end;
  75. type
  76. tregableinfoflag = (
  77. // can be put in a register if it's the address of a var/out/const parameter
  78. ra_addr_regable,
  79. // orthogonal to above flag: the address of the node is taken and may
  80. // possibly escape the block in which this node is declared (e.g. a
  81. // local variable is passed as var parameter to another procedure)
  82. ra_addr_taken);
  83. tregableinfoflags = set of tregableinfoflag;
  84. const
  85. tok2nodes=24;
  86. tok2node:array[1..tok2nodes] of ttok2noderec=(
  87. (tok:_PLUS ;nod:addn;op_overloading_supported:true), { binary overloading supported }
  88. (tok:_MINUS ;nod:subn;op_overloading_supported:true), { binary and unary overloading supported }
  89. (tok:_STAR ;nod:muln;op_overloading_supported:true), { binary overloading supported }
  90. (tok:_SLASH ;nod:slashn;op_overloading_supported:true), { binary overloading supported }
  91. (tok:_EQUAL ;nod:equaln;op_overloading_supported:true), { binary overloading supported }
  92. (tok:_GT ;nod:gtn;op_overloading_supported:true), { binary overloading supported }
  93. (tok:_LT ;nod:ltn;op_overloading_supported:true), { binary overloading supported }
  94. (tok:_GTE ;nod:gten;op_overloading_supported:true), { binary overloading supported }
  95. (tok:_LTE ;nod:lten;op_overloading_supported:true), { binary overloading supported }
  96. (tok:_SYMDIF ;nod:symdifn;op_overloading_supported:true), { binary overloading supported }
  97. (tok:_STARSTAR;nod:starstarn;op_overloading_supported:true), { binary overloading supported }
  98. (tok:_OP_AS ;nod:asn;op_overloading_supported:false), { binary overloading NOT supported }
  99. (tok:_OP_IN ;nod:inn;op_overloading_supported:false), { binary overloading NOT supported }
  100. (tok:_OP_IS ;nod:isn;op_overloading_supported:false), { binary overloading NOT supported }
  101. (tok:_OP_OR ;nod:orn;op_overloading_supported:true), { binary overloading supported }
  102. (tok:_OP_AND ;nod:andn;op_overloading_supported:true), { binary overloading supported }
  103. (tok:_OP_DIV ;nod:divn;op_overloading_supported:true), { binary overloading supported }
  104. (tok:_OP_NOT ;nod:notn;op_overloading_supported:true), { unary overloading supported }
  105. (tok:_OP_MOD ;nod:modn;op_overloading_supported:true), { binary overloading supported }
  106. (tok:_OP_SHL ;nod:shln;op_overloading_supported:true), { binary overloading supported }
  107. (tok:_OP_SHR ;nod:shrn;op_overloading_supported:true), { binary overloading supported }
  108. (tok:_OP_XOR ;nod:xorn;op_overloading_supported:true), { binary overloading supported }
  109. (tok:_ASSIGNMENT;nod:assignn;op_overloading_supported:true), { unary overloading supported }
  110. (tok:_UNEQUAL ;nod:unequaln;op_overloading_supported:false) { binary overloading NOT supported overload = instead }
  111. );
  112. { true, if we are parsing stuff which allows array constructors }
  113. allow_array_constructor : boolean = false;
  114. function node2opstr(nt:tnodetype):string;
  115. { check operator args and result type }
  116. function isbinaryoperatoroverloadable(treetyp:tnodetype;ld:tdef;lt:tnodetype;rd:tdef;rt:tnodetype) : boolean;
  117. function isoperatoracceptable(pf : tprocdef; optoken : ttoken) : boolean;
  118. function isunaryoverloaded(var t : tnode) : boolean;
  119. function isbinaryoverloaded(var t : tnode) : boolean;
  120. { Register Allocation }
  121. procedure make_not_regable(p : tnode; how: tregableinfoflags);
  122. { procvar handling }
  123. function is_procvar_load(p:tnode):boolean;
  124. procedure test_local_to_procvar(from_def:tprocvardef;to_def:tdef);
  125. { sets varsym varstate field correctly }
  126. type
  127. tvarstateflag = (vsf_must_be_valid,vsf_use_hints);
  128. tvarstateflags = set of tvarstateflag;
  129. procedure set_varstate(p:tnode;newstate:tvarstate;varstateflags:tvarstateflags);
  130. { sets the callunique flag, if the node is a vecn, }
  131. { takes care of type casts etc. }
  132. procedure set_unique(p : tnode);
  133. function valid_for_formal_var(p : tnode; report_errors: boolean) : boolean;
  134. function valid_for_formal_const(p : tnode; report_errors: boolean) : boolean;
  135. function valid_for_var(p:tnode; report_errors: boolean):boolean;
  136. function valid_for_assignment(p:tnode; report_errors: boolean):boolean;
  137. function valid_for_loopvar(p:tnode; report_errors: boolean):boolean;
  138. function valid_for_addr(p : tnode; report_errors: boolean) : boolean;
  139. function allowenumop(nt:tnodetype):boolean;
  140. procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring);
  141. procedure check_ranges(const location: tfileposinfo; source: tnode; destdef: tdef);
  142. implementation
  143. uses
  144. sysutils,
  145. systems,constexp,globals,
  146. cutils,verbose,
  147. symtable,
  148. defutil,defcmp,
  149. nbas,ncnv,nld,nmem,ncal,nmat,ninl,nutils,ncon,
  150. cgbase,procinfo
  151. ;
  152. type
  153. TValidAssign=(Valid_Property,Valid_Void,Valid_Const,Valid_Addr,Valid_Packed);
  154. TValidAssigns=set of TValidAssign;
  155. function node2opstr(nt:tnodetype):string;
  156. var
  157. i : integer;
  158. begin
  159. result:='<unknown>';
  160. for i:=1 to tok2nodes do
  161. if tok2node[i].nod=nt then
  162. begin
  163. result:=tokeninfo^[tok2node[i].tok].str;
  164. break;
  165. end;
  166. end;
  167. function isbinaryoperatoroverloadable(treetyp:tnodetype;ld:tdef;lt:tnodetype;rd:tdef;rt:tnodetype) : boolean;
  168. function internal_check(treetyp:tnodetype;ld:tdef;lt:tnodetype;rd:tdef;rt:tnodetype;var allowed:boolean):boolean;
  169. begin
  170. internal_check:=true;
  171. case ld.typ of
  172. formaldef,
  173. recorddef,
  174. variantdef :
  175. begin
  176. allowed:=true;
  177. end;
  178. procvardef :
  179. begin
  180. if (rd.typ in [pointerdef,procdef,procvardef]) then
  181. begin
  182. allowed:=false;
  183. exit;
  184. end;
  185. allowed:=true;
  186. end;
  187. pointerdef :
  188. begin
  189. if ((rd.typ in [orddef,enumdef,pointerdef,classrefdef,procvardef]) or
  190. is_class_or_interface_or_dispinterface_or_objc(rd)) then
  191. begin
  192. allowed:=false;
  193. exit;
  194. end;
  195. { don't allow pchar+string }
  196. if (is_pchar(ld) or is_pwidechar(ld)) and
  197. ((rd.typ=stringdef) or
  198. is_pchar(rd) or
  199. is_pwidechar(rd) or
  200. is_chararray(rd) or
  201. is_widechararray(rd)) then
  202. begin
  203. allowed:=false;
  204. exit;
  205. end;
  206. allowed:=true;
  207. end;
  208. arraydef :
  209. begin
  210. { not vector/mmx }
  211. if ((cs_mmx in current_settings.localswitches) and
  212. is_mmx_able_array(ld)) or
  213. ((cs_support_vectors in current_settings.globalswitches) and
  214. is_vector(ld)) then
  215. begin
  216. allowed:=false;
  217. exit;
  218. end;
  219. { not chararray+[(wide)char,(wide)string,(wide)chararray] }
  220. if (is_chararray(ld) or is_widechararray(ld) or
  221. is_open_chararray(ld) or is_open_widechararray(ld))
  222. and
  223. ((rd.typ in [stringdef,orddef,enumdef]) or
  224. is_pchar(rd) or
  225. is_pwidechar(rd) or
  226. is_chararray(rd) or
  227. is_widechararray(rd) or
  228. is_open_chararray(rd) or
  229. is_open_widechararray(rd) or
  230. (rt=niln)) then
  231. begin
  232. allowed:=false;
  233. exit;
  234. end;
  235. { dynamic array compare with niln }
  236. if ((is_dynamic_array(ld) and
  237. (rt=niln)) or
  238. (is_dynamic_array(ld) and is_dynamic_array(rd)))
  239. and
  240. (treetyp in [equaln,unequaln]) then
  241. begin
  242. allowed:=false;
  243. exit;
  244. end;
  245. allowed:=true;
  246. end;
  247. objectdef :
  248. begin
  249. { <> and = are defined for classes }
  250. if (treetyp in [equaln,unequaln]) and
  251. is_class_or_interface_or_dispinterface_or_objc(ld) then
  252. begin
  253. allowed:=false;
  254. exit;
  255. end;
  256. allowed:=true;
  257. end;
  258. stringdef :
  259. begin
  260. if (rd.typ in [orddef,enumdef,stringdef]) or
  261. is_pchar(rd) or
  262. is_pwidechar(rd) or
  263. is_chararray(rd) or
  264. is_widechararray(rd) or
  265. is_open_chararray(rd) or
  266. is_open_widechararray(rd) then
  267. begin
  268. allowed:=false;
  269. exit;
  270. end;
  271. allowed:=true;
  272. end;
  273. else
  274. internal_check:=false;
  275. end;
  276. end;
  277. var
  278. allowed : boolean;
  279. begin
  280. { power ** is always possible }
  281. if (treetyp=starstarn) then
  282. begin
  283. isbinaryoperatoroverloadable:=true;
  284. exit;
  285. end;
  286. { order of arguments does not matter so we have to check also
  287. the reversed order }
  288. allowed:=false;
  289. if not internal_check(treetyp,ld,lt,rd,rt,allowed) then
  290. internal_check(treetyp,rd,rt,ld,lt,allowed);
  291. isbinaryoperatoroverloadable:=allowed;
  292. end;
  293. function isunaryoperatoroverloadable(treetyp : tnodetype;ld : tdef) : boolean;
  294. begin
  295. result:=false;
  296. case treetyp of
  297. subn,
  298. unaryminusn :
  299. begin
  300. if (ld.typ in [orddef,enumdef,floatdef]) then
  301. exit;
  302. {$ifdef SUPPORT_MMX}
  303. if (cs_mmx in current_settings.localswitches) and
  304. is_mmx_able_array(ld) then
  305. exit;
  306. {$endif SUPPORT_MMX}
  307. result:=true;
  308. end;
  309. notn :
  310. begin
  311. if (ld.typ in [orddef,enumdef,floatdef]) then
  312. exit;
  313. {$ifdef SUPPORT_MMX}
  314. if (cs_mmx in current_settings.localswitches) and
  315. is_mmx_able_array(ld) then
  316. exit;
  317. {$endif SUPPORT_MMX}
  318. result:=true;
  319. end;
  320. end;
  321. end;
  322. function isoperatoracceptable(pf : tprocdef; optoken : ttoken) : boolean;
  323. var
  324. ld,rd : tdef;
  325. i : longint;
  326. eq : tequaltype;
  327. conv : tconverttype;
  328. pd : tprocdef;
  329. oldcount,
  330. count: longint;
  331. parasym : tparavarsym;
  332. begin
  333. result:=false;
  334. count := pf.parast.SymList.count;
  335. oldcount:=count;
  336. while count > 0 do
  337. begin
  338. parasym:=tparavarsym(pf.parast.SymList[count-1]);
  339. if is_boolean(parasym.vardef) then
  340. begin
  341. if parasym.name='RANGECHECK' then
  342. begin
  343. Include(parasym.varoptions, vo_is_hidden_para);
  344. Include(parasym.varoptions, vo_is_range_check);
  345. Dec(count);
  346. end
  347. else if parasym.name='OVERFLOWCHECK' then
  348. begin
  349. Include(parasym.varoptions, vo_is_hidden_para);
  350. Include(parasym.varoptions, vo_is_overflow_check);
  351. Dec(count);
  352. end
  353. else
  354. break;
  355. end
  356. else
  357. break;
  358. end;
  359. if count<>oldcount then
  360. pf.calcparas;
  361. case count of
  362. 1 : begin
  363. ld:=tparavarsym(pf.parast.SymList[0]).vardef;
  364. { assignment is a special case }
  365. if optoken=_ASSIGNMENT then
  366. begin
  367. eq:=compare_defs_ext(ld,pf.returndef,nothingn,conv,pd,[cdo_explicit]);
  368. result:=
  369. (eq=te_incompatible) and
  370. { don't allow overloading assigning to custom shortstring
  371. types, because we also don't want to differentiate based
  372. on different shortstring types (e.g.,
  373. "operator :=(const v: variant) res: shorstring" also
  374. has to work for assigning a variant to a string[80])
  375. }
  376. (not is_shortstring(pf.returndef) or
  377. (tstringdef(pf.returndef).len=255));
  378. end
  379. else
  380. { enumerator is a special case too }
  381. if optoken=_OP_ENUMERATOR then
  382. begin
  383. result:=
  384. is_class_or_interface_or_object(pf.returndef);
  385. end
  386. else
  387. begin
  388. for i:=1 to tok2nodes do
  389. if tok2node[i].tok=optoken then
  390. begin
  391. result:=
  392. tok2node[i].op_overloading_supported and
  393. isunaryoperatoroverloadable(tok2node[i].nod,ld);
  394. break;
  395. end;
  396. end;
  397. end;
  398. 2 : begin
  399. for i:=1 to tok2nodes do
  400. if tok2node[i].tok=optoken then
  401. begin
  402. ld:=tparavarsym(pf.parast.SymList[0]).vardef;
  403. rd:=tparavarsym(pf.parast.SymList[1]).vardef;
  404. result:=
  405. tok2node[i].op_overloading_supported and
  406. isbinaryoperatoroverloadable(tok2node[i].nod,ld,nothingn,rd,nothingn);
  407. break;
  408. end;
  409. end;
  410. end;
  411. end;
  412. function isunaryoverloaded(var t : tnode) : boolean;
  413. var
  414. ld : tdef;
  415. optoken : ttoken;
  416. operpd : tprocdef;
  417. ppn : tcallparanode;
  418. candidates : tcallcandidates;
  419. cand_cnt : integer;
  420. begin
  421. result:=false;
  422. operpd:=nil;
  423. { load easier access variables }
  424. ld:=tunarynode(t).left.resultdef;
  425. if not isunaryoperatoroverloadable(t.nodetype,ld) then
  426. exit;
  427. { operator overload is possible }
  428. result:=true;
  429. case t.nodetype of
  430. notn:
  431. optoken:=_OP_NOT;
  432. unaryminusn:
  433. optoken:=_MINUS;
  434. else
  435. begin
  436. CGMessage(parser_e_operator_not_overloaded);
  437. t:=cnothingnode.create;
  438. exit;
  439. end;
  440. end;
  441. { generate parameter nodes }
  442. ppn:=ccallparanode.create(tunarynode(t).left.getcopy,nil);
  443. ppn.get_paratype;
  444. candidates:=tcallcandidates.create_operator(optoken,ppn);
  445. { stop when there are no operators found }
  446. if candidates.count=0 then
  447. begin
  448. CGMessage2(parser_e_operator_not_overloaded_2,ld.gettypename,arraytokeninfo[optoken].str);
  449. candidates.free;
  450. ppn.free;
  451. t:=cnothingnode.create;
  452. exit;
  453. end;
  454. { Retrieve information about the candidates }
  455. candidates.get_information;
  456. {$ifdef EXTDEBUG}
  457. { Display info when multiple candidates are found }
  458. candidates.dump_info(V_Debug);
  459. {$endif EXTDEBUG}
  460. cand_cnt:=candidates.choose_best(tabstractprocdef(operpd),false);
  461. { exit when no overloads are found }
  462. if cand_cnt=0 then
  463. begin
  464. CGMessage2(parser_e_operator_not_overloaded_2,ld.gettypename,arraytokeninfo[optoken].str);
  465. candidates.free;
  466. ppn.free;
  467. t:=cnothingnode.create;
  468. exit;
  469. end;
  470. { Multiple candidates left? }
  471. if cand_cnt>1 then
  472. begin
  473. CGMessage(type_e_cant_choose_overload_function);
  474. {$ifdef EXTDEBUG}
  475. candidates.dump_info(V_Hint);
  476. {$else EXTDEBUG}
  477. candidates.list(false);
  478. {$endif EXTDEBUG}
  479. { we'll just use the first candidate to make the
  480. call }
  481. end;
  482. candidates.free;
  483. addsymref(operpd.procsym);
  484. { the nil as symtable signs firstcalln that this is
  485. an overloaded operator }
  486. t:=ccallnode.create(ppn,Tprocsym(operpd.procsym),nil,nil,[]);
  487. { we already know the procdef to use, so it can
  488. skip the overload choosing in callnode.pass_typecheck }
  489. tcallnode(t).procdefinition:=operpd;
  490. end;
  491. function isbinaryoverloaded(var t : tnode) : boolean;
  492. var
  493. rd,ld : tdef;
  494. optoken : ttoken;
  495. operpd : tprocdef;
  496. ht : tnode;
  497. ppn : tcallparanode;
  498. candidates : tcallcandidates;
  499. cand_cnt : integer;
  500. begin
  501. isbinaryoverloaded:=false;
  502. operpd:=nil;
  503. { load easier access variables }
  504. ld:=tbinarynode(t).left.resultdef;
  505. rd:=tbinarynode(t).right.resultdef;
  506. if not isbinaryoperatoroverloadable(t.nodetype,ld,tbinarynode(t).left.nodetype,rd,tbinarynode(t).right.nodetype) then
  507. exit;
  508. { operator overload is possible }
  509. result:=true;
  510. case t.nodetype of
  511. equaln,
  512. unequaln :
  513. optoken:=_EQUAL;
  514. addn:
  515. optoken:=_PLUS;
  516. subn:
  517. optoken:=_MINUS;
  518. muln:
  519. optoken:=_STAR;
  520. starstarn:
  521. optoken:=_STARSTAR;
  522. slashn:
  523. optoken:=_SLASH;
  524. ltn:
  525. optoken:=_LT;
  526. gtn:
  527. optoken:=_GT;
  528. lten:
  529. optoken:=_LTE;
  530. gten:
  531. optoken:=_GTE;
  532. symdifn :
  533. optoken:=_SYMDIF;
  534. modn :
  535. optoken:=_OP_MOD;
  536. orn :
  537. optoken:=_OP_OR;
  538. xorn :
  539. optoken:=_OP_XOR;
  540. andn :
  541. optoken:=_OP_AND;
  542. divn :
  543. optoken:=_OP_DIV;
  544. shln :
  545. optoken:=_OP_SHL;
  546. shrn :
  547. optoken:=_OP_SHR;
  548. else
  549. begin
  550. CGMessage(parser_e_operator_not_overloaded);
  551. t:=cnothingnode.create;
  552. exit;
  553. end;
  554. end;
  555. { generate parameter nodes }
  556. ppn:=ccallparanode.create(tbinarynode(t).right.getcopy,ccallparanode.create(tbinarynode(t).left.getcopy,nil));
  557. ppn.get_paratype;
  558. candidates:=tcallcandidates.create_operator(optoken,ppn);
  559. { for commutative operators we can swap arguments and try again }
  560. if (candidates.count=0) and
  561. not(optoken in [_OP_SHL,_OP_SHR,_OP_DIV,_OP_MOD,_STARSTAR,_SLASH,_MINUS]) then
  562. begin
  563. candidates.free;
  564. reverseparameters(ppn);
  565. { reverse compare operators }
  566. case optoken of
  567. _LT:
  568. optoken:=_GTE;
  569. _GT:
  570. optoken:=_LTE;
  571. _LTE:
  572. optoken:=_GT;
  573. _GTE:
  574. optoken:=_LT;
  575. end;
  576. candidates:=tcallcandidates.create_operator(optoken,ppn);
  577. end;
  578. { stop when there are no operators found }
  579. if candidates.count=0 then
  580. begin
  581. CGMessage(parser_e_operator_not_overloaded);
  582. candidates.free;
  583. ppn.free;
  584. t:=cnothingnode.create;
  585. exit;
  586. end;
  587. { Retrieve information about the candidates }
  588. candidates.get_information;
  589. {$ifdef EXTDEBUG}
  590. { Display info when multiple candidates are found }
  591. candidates.dump_info(V_Debug);
  592. {$endif EXTDEBUG}
  593. cand_cnt:=candidates.choose_best(tabstractprocdef(operpd),false);
  594. { exit when no overloads are found }
  595. if cand_cnt=0 then
  596. begin
  597. CGMessage3(parser_e_operator_not_overloaded_3,ld.gettypename,arraytokeninfo[optoken].str,rd.gettypename);
  598. candidates.free;
  599. ppn.free;
  600. t:=cnothingnode.create;
  601. exit;
  602. end;
  603. { Multiple candidates left? }
  604. if cand_cnt>1 then
  605. begin
  606. CGMessage(type_e_cant_choose_overload_function);
  607. {$ifdef EXTDEBUG}
  608. candidates.dump_info(V_Hint);
  609. {$else EXTDEBUG}
  610. candidates.list(false);
  611. {$endif EXTDEBUG}
  612. { we'll just use the first candidate to make the
  613. call }
  614. end;
  615. candidates.free;
  616. addsymref(operpd.procsym);
  617. { the nil as symtable signs firstcalln that this is
  618. an overloaded operator }
  619. ht:=ccallnode.create(ppn,Tprocsym(operpd.procsym),nil,nil,[]);
  620. { we already know the procdef to use, so it can
  621. skip the overload choosing in callnode.pass_typecheck }
  622. tcallnode(ht).procdefinition:=operpd;
  623. if t.nodetype=unequaln then
  624. ht:=cnotnode.create(ht);
  625. t:=ht;
  626. end;
  627. {****************************************************************************
  628. Register Calculation
  629. ****************************************************************************}
  630. { marks an lvalue as "unregable" }
  631. procedure make_not_regable_intern(p : tnode; how: tregableinfoflags; records_only: boolean);
  632. var
  633. update_regable: boolean;
  634. begin
  635. update_regable:=true;
  636. repeat
  637. case p.nodetype of
  638. subscriptn:
  639. begin
  640. records_only:=true;
  641. p:=tsubscriptnode(p).left;
  642. end;
  643. vecn:
  644. begin
  645. { arrays are currently never regable and pointers indexed like }
  646. { arrays do not have be made unregable, but we do need to }
  647. { propagate the ra_addr_taken info }
  648. update_regable:=false;
  649. p:=tvecnode(p).left;
  650. end;
  651. typeconvn :
  652. begin
  653. if (ttypeconvnode(p).resultdef.typ = recorddef) then
  654. records_only:=false;
  655. p:=ttypeconvnode(p).left;
  656. end;
  657. loadn :
  658. begin
  659. if (tloadnode(p).symtableentry.typ in [staticvarsym,localvarsym,paravarsym]) then
  660. begin
  661. if (ra_addr_taken in how) then
  662. tabstractvarsym(tloadnode(p).symtableentry).addr_taken:=true;
  663. if update_regable and
  664. (tabstractvarsym(tloadnode(p).symtableentry).varregable <> vr_none) and
  665. ((not records_only) or
  666. (tabstractvarsym(tloadnode(p).symtableentry).vardef.typ = recorddef)) then
  667. if (tloadnode(p).symtableentry.typ = paravarsym) and
  668. (ra_addr_regable in how) then
  669. tabstractvarsym(tloadnode(p).symtableentry).varregable:=vr_addr
  670. else
  671. tabstractvarsym(tloadnode(p).symtableentry).varregable:=vr_none;
  672. end;
  673. break;
  674. end;
  675. temprefn :
  676. begin
  677. if (ra_addr_taken in how) then
  678. include(ttemprefnode(p).tempinfo^.flags,ti_addr_taken);
  679. if update_regable and
  680. (ti_may_be_in_reg in ttemprefnode(p).tempinfo^.flags) and
  681. ((not records_only) or
  682. (ttemprefnode(p).tempinfo^.typedef.typ = recorddef)) then
  683. exclude(ttemprefnode(p).tempinfo^.flags,ti_may_be_in_reg);
  684. break;
  685. end;
  686. else
  687. break;
  688. end;
  689. until false;
  690. end;
  691. procedure make_not_regable(p : tnode; how: tregableinfoflags);
  692. begin
  693. make_not_regable_intern(p,how,false);
  694. end;
  695. {****************************************************************************
  696. Subroutine Handling
  697. ****************************************************************************}
  698. function is_procvar_load(p:tnode):boolean;
  699. begin
  700. result:=false;
  701. { remove voidpointer typecast for tp procvars }
  702. if ((m_tp_procvar in current_settings.modeswitches) or
  703. (m_mac_procvar in current_settings.modeswitches)) and
  704. (p.nodetype=typeconvn) and
  705. is_voidpointer(p.resultdef) then
  706. p:=tunarynode(p).left;
  707. result:=(p.nodetype=typeconvn) and
  708. (ttypeconvnode(p).convtype=tc_proc_2_procvar);
  709. end;
  710. { local routines can't be assigned to procvars }
  711. procedure test_local_to_procvar(from_def:tprocvardef;to_def:tdef);
  712. begin
  713. if (from_def.parast.symtablelevel>normal_function_level) and
  714. (to_def.typ=procvardef) then
  715. CGMessage(type_e_cannot_local_proc_to_procvar);
  716. end;
  717. procedure set_varstate(p:tnode;newstate:tvarstate;varstateflags:tvarstateflags);
  718. const
  719. vstrans: array[tvarstate,tvarstate] of tvarstate = (
  720. { vs_none -> ... }
  721. (vs_none,vs_declared,vs_initialised,vs_read,vs_read_not_warned,vs_referred_not_inited,vs_written,vs_readwritten),
  722. { vs_declared -> ... }
  723. (vs_none,vs_declared,vs_initialised,vs_read,vs_read_not_warned,vs_referred_not_inited,vs_written,vs_readwritten),
  724. { vs_initialised -> ... }
  725. (vs_none,vs_initialised,vs_initialised,vs_read,vs_read,vs_read,vs_written,vs_readwritten),
  726. { vs_read -> ... }
  727. (vs_none,vs_read,vs_read,vs_read,vs_read,vs_read,vs_readwritten,vs_readwritten),
  728. { vs_read_not_warned -> ... }
  729. (vs_none,vs_read_not_warned,vs_read,vs_read,vs_read_not_warned,vs_read_not_warned,vs_readwritten,vs_readwritten),
  730. { vs_referred_not_inited }
  731. (vs_none,vs_referred_not_inited,vs_read,vs_read,vs_read_not_warned,vs_referred_not_inited,vs_written,vs_readwritten),
  732. { vs_written -> ... }
  733. (vs_none,vs_written,vs_written,vs_readwritten,vs_readwritten,vs_written,vs_written,vs_readwritten),
  734. { vs_readwritten -> ... }
  735. (vs_none,vs_readwritten,vs_readwritten,vs_readwritten,vs_readwritten,vs_readwritten,vs_readwritten,vs_readwritten));
  736. var
  737. hsym : tabstractvarsym;
  738. begin
  739. { make sure we can still warn about uninitialised use after high(v), @v etc }
  740. if (newstate = vs_read) and
  741. not(vsf_must_be_valid in varstateflags) then
  742. newstate := vs_referred_not_inited;
  743. while assigned(p) do
  744. begin
  745. case p.nodetype of
  746. derefn:
  747. begin
  748. if (tderefnode(p).left.nodetype=temprefn) and
  749. assigned(ttemprefnode(tderefnode(p).left).tempinfo^.withnode) then
  750. p:=ttemprefnode(tderefnode(p).left).tempinfo^.withnode
  751. else
  752. break;
  753. end;
  754. typeconvn :
  755. begin
  756. case ttypeconvnode(p).convtype of
  757. tc_cchar_2_pchar,
  758. tc_cstring_2_pchar,
  759. tc_array_2_pointer :
  760. exclude(varstateflags,vsf_must_be_valid);
  761. tc_pchar_2_string,
  762. tc_pointer_2_array :
  763. include(varstateflags,vsf_must_be_valid);
  764. end;
  765. p:=tunarynode(p).left;
  766. end;
  767. subscriptn :
  768. begin
  769. if is_class_or_interface_or_dispinterface_or_objc(tunarynode(p).left.resultdef) then
  770. newstate := vs_read;
  771. p:=tunarynode(p).left;
  772. end;
  773. vecn:
  774. begin
  775. set_varstate(tbinarynode(p).right,vs_read,[vsf_must_be_valid]);
  776. if (newstate in [vs_read,vs_readwritten]) or
  777. not(tunarynode(p).left.resultdef.typ in [stringdef,arraydef]) then
  778. include(varstateflags,vsf_must_be_valid)
  779. else if (newstate = vs_written) then
  780. exclude(varstateflags,vsf_must_be_valid);
  781. p:=tunarynode(p).left;
  782. end;
  783. { do not parse calln }
  784. calln :
  785. break;
  786. loadn :
  787. begin
  788. if (tloadnode(p).symtableentry.typ in [localvarsym,paravarsym,staticvarsym]) then
  789. begin
  790. hsym:=tabstractvarsym(tloadnode(p).symtableentry);
  791. if (vsf_must_be_valid in varstateflags) and
  792. (hsym.varstate in [vs_declared,vs_read_not_warned,vs_referred_not_inited]) then
  793. begin
  794. { Give warning/note for uninitialized locals }
  795. if assigned(hsym.owner) and
  796. not(cs_opt_nodedfa in current_settings.optimizerswitches) and
  797. not(vo_is_external in hsym.varoptions) and
  798. (hsym.owner.symtabletype in [parasymtable,localsymtable,staticsymtable]) and
  799. ((hsym.owner=current_procinfo.procdef.localst) or
  800. (hsym.owner=current_procinfo.procdef.parast)) then
  801. begin
  802. if (vo_is_funcret in hsym.varoptions) then
  803. begin
  804. if (vsf_use_hints in varstateflags) then
  805. CGMessagePos(p.fileinfo,sym_h_function_result_uninitialized)
  806. else
  807. CGMessagePos(p.fileinfo,sym_w_function_result_uninitialized)
  808. end
  809. else
  810. begin
  811. if tloadnode(p).symtable.symtabletype=localsymtable then
  812. begin
  813. if (vsf_use_hints in varstateflags) then
  814. CGMessagePos1(p.fileinfo,sym_h_uninitialized_local_variable,hsym.realname)
  815. else
  816. CGMessagePos1(p.fileinfo,sym_w_uninitialized_local_variable,hsym.realname);
  817. end
  818. else
  819. begin
  820. if (vsf_use_hints in varstateflags) then
  821. CGMessagePos1(p.fileinfo,sym_h_uninitialized_variable,hsym.realname)
  822. else
  823. CGMessagePos1(p.fileinfo,sym_w_uninitialized_variable,hsym.realname);
  824. end;
  825. end;
  826. end
  827. else if (newstate = vs_read) then
  828. newstate := vs_read_not_warned;
  829. end;
  830. hsym.varstate := vstrans[hsym.varstate,newstate];
  831. end;
  832. case newstate of
  833. vs_written:
  834. include(tloadnode(p).flags,nf_write);
  835. vs_readwritten:
  836. if not(nf_write in tloadnode(p).flags) then
  837. include(tloadnode(p).flags,nf_modify);
  838. end;
  839. break;
  840. end;
  841. callparan :
  842. internalerror(200310081);
  843. else
  844. break;
  845. end;{case }
  846. end;
  847. end;
  848. procedure set_unique(p : tnode);
  849. begin
  850. while assigned(p) do
  851. begin
  852. case p.nodetype of
  853. vecn:
  854. begin
  855. include(p.flags,nf_callunique);
  856. break;
  857. end;
  858. typeconvn,
  859. subscriptn,
  860. derefn:
  861. p:=tunarynode(p).left;
  862. else
  863. break;
  864. end;
  865. end;
  866. end;
  867. function valid_for_assign(p:tnode;opts:TValidAssigns; report_errors: boolean):boolean;
  868. var
  869. hp2,
  870. hp : tnode;
  871. gotstring,
  872. gotsubscript,
  873. gotrecord,
  874. gotpointer,
  875. gotvec,
  876. gotclass,
  877. gotdynarray,
  878. gotderef,
  879. gottypeconv : boolean;
  880. fromdef,
  881. todef : tdef;
  882. errmsg,
  883. temp : longint;
  884. begin
  885. if valid_const in opts then
  886. errmsg:=type_e_variable_id_expected
  887. else if valid_property in opts then
  888. errmsg:=type_e_argument_cant_be_assigned
  889. else
  890. errmsg:=type_e_no_addr_of_constant;
  891. result:=false;
  892. gotsubscript:=false;
  893. gotvec:=false;
  894. gotderef:=false;
  895. gotrecord:=false;
  896. gotclass:=false;
  897. gotpointer:=false;
  898. gotdynarray:=false;
  899. gotstring:=false;
  900. gottypeconv:=false;
  901. hp:=p;
  902. if not(valid_void in opts) and
  903. is_void(hp.resultdef) then
  904. begin
  905. if report_errors then
  906. CGMessagePos(hp.fileinfo,errmsg);
  907. exit;
  908. end;
  909. while assigned(hp) do
  910. begin
  911. { property allowed? calln has a property check itself }
  912. if (nf_isproperty in hp.flags) then
  913. begin
  914. { check return type }
  915. case hp.resultdef.typ of
  916. pointerdef :
  917. gotpointer:=true;
  918. objectdef :
  919. gotclass:=is_class_or_interface_or_dispinterface_or_objc(hp.resultdef);
  920. recorddef :
  921. gotrecord:=true;
  922. classrefdef :
  923. gotclass:=true;
  924. stringdef :
  925. gotstring:=true;
  926. end;
  927. if (valid_property in opts) then
  928. begin
  929. { don't allow writing to calls that will create
  930. temps like calls that return a structure and we
  931. are assigning to a member }
  932. if (valid_const in opts) or
  933. { if we got a deref, we won't modify the property itself }
  934. (gotderef) or
  935. { same when we got a class and subscript (= deref) }
  936. (gotclass and gotsubscript) or
  937. (
  938. { allowing assignments to typecasted properties
  939. a) is Delphi-incompatible
  940. b) causes problems in case the getter is a function
  941. (because then the result of the getter is
  942. typecasted to this type, and then we "assign" to
  943. this typecasted function result) -> always
  944. disallow, since property accessors should be
  945. transparantly changeable to functions at all
  946. times
  947. }
  948. not(gottypeconv) and
  949. not(gotsubscript and gotrecord) and
  950. not(gotstring and gotvec)
  951. ) then
  952. result:=true
  953. else
  954. if report_errors then
  955. CGMessagePos(hp.fileinfo,errmsg);
  956. end
  957. else
  958. begin
  959. { 1. if it returns a pointer and we've found a deref,
  960. 2. if it returns a class or record and a subscription or with is found
  961. 3. if the address is needed of a field (subscriptn, vecn) }
  962. if (gotpointer and gotderef) or
  963. (gotstring and gotvec) or
  964. (
  965. (gotclass or gotrecord) and
  966. (gotsubscript)
  967. ) or
  968. (
  969. (gotvec and gotdynarray)
  970. ) or
  971. (
  972. (Valid_Addr in opts) and
  973. (hp.nodetype in [subscriptn,vecn])
  974. ) then
  975. result:=true
  976. else
  977. if report_errors then
  978. CGMessagePos(hp.fileinfo,errmsg);
  979. end;
  980. exit;
  981. end;
  982. case hp.nodetype of
  983. temprefn :
  984. begin
  985. valid_for_assign := true;
  986. exit;
  987. end;
  988. derefn :
  989. begin
  990. gotderef:=true;
  991. hp:=tderefnode(hp).left;
  992. end;
  993. typeconvn :
  994. begin
  995. gottypeconv:=true;
  996. { typecast sizes must match, exceptions:
  997. - implicit typecast made by absolute
  998. - from formaldef
  999. - from void
  1000. - from/to open array
  1001. - typecast from pointer to array }
  1002. fromdef:=ttypeconvnode(hp).left.resultdef;
  1003. todef:=hp.resultdef;
  1004. if not((nf_absolute in ttypeconvnode(hp).flags) or
  1005. (fromdef.typ=formaldef) or
  1006. is_void(fromdef) or
  1007. is_open_array(fromdef) or
  1008. is_open_array(todef) or
  1009. ((fromdef.typ=pointerdef) and (todef.typ=arraydef)) or
  1010. ((fromdef.typ = objectdef) and (todef.typ = objectdef) and
  1011. (tobjectdef(fromdef).is_related(tobjectdef(todef))))) and
  1012. (fromdef.size<>todef.size) then
  1013. begin
  1014. { in TP it is allowed to typecast to smaller types. But the variable can't
  1015. be in a register }
  1016. if (m_tp7 in current_settings.modeswitches) or
  1017. (todef.size<fromdef.size) then
  1018. make_not_regable(hp,[ra_addr_regable])
  1019. else
  1020. if report_errors then
  1021. CGMessagePos2(hp.fileinfo,type_e_typecast_wrong_size_for_assignment,tostr(fromdef.size),tostr(todef.size));
  1022. end;
  1023. { don't allow assignments to typeconvs that need special code }
  1024. if not(gotsubscript or gotvec or gotderef) and
  1025. not(ttypeconvnode(hp).assign_allowed) then
  1026. begin
  1027. if report_errors then
  1028. CGMessagePos(hp.fileinfo,errmsg);
  1029. exit;
  1030. end;
  1031. case hp.resultdef.typ of
  1032. pointerdef :
  1033. gotpointer:=true;
  1034. objectdef :
  1035. gotclass:=is_class_or_interface_or_dispinterface_or_objc(hp.resultdef);
  1036. classrefdef :
  1037. gotclass:=true;
  1038. arraydef :
  1039. begin
  1040. { pointer -> array conversion is done then we need to see it
  1041. as a deref, because a ^ is then not required anymore }
  1042. if (ttypeconvnode(hp).left.resultdef.typ=pointerdef) then
  1043. gotderef:=true;
  1044. end;
  1045. end;
  1046. hp:=ttypeconvnode(hp).left;
  1047. end;
  1048. vecn :
  1049. begin
  1050. if { only check for first (= outermost) vec node }
  1051. not gotvec and
  1052. not(valid_packed in opts) and
  1053. (tvecnode(hp).left.resultdef.typ = arraydef) and
  1054. (ado_IsBitPacked in tarraydef(tvecnode(hp).left.resultdef).arrayoptions) and
  1055. ((tarraydef(tvecnode(hp).left.resultdef).elepackedbitsize mod 8 <> 0) or
  1056. (is_ordinal(tarraydef(tvecnode(hp).left.resultdef).elementdef) and
  1057. not ispowerof2(tarraydef(tvecnode(hp).left.resultdef).elepackedbitsize div 8,temp))) then
  1058. begin
  1059. if report_errors then
  1060. if (valid_property in opts) then
  1061. CGMessagePos(hp.fileinfo,parser_e_packed_element_no_loop)
  1062. else
  1063. CGMessagePos(hp.fileinfo,parser_e_packed_element_no_var_addr);
  1064. exit;
  1065. end;
  1066. gotvec:=true;
  1067. { accesses to dyn. arrays override read only access in delphi }
  1068. if (m_delphi in current_settings.modeswitches) and is_dynamic_array(tunarynode(hp).left.resultdef) then
  1069. gotdynarray:=true;
  1070. hp:=tunarynode(hp).left;
  1071. end;
  1072. blockn :
  1073. begin
  1074. hp2:=tblocknode(hp).statements;
  1075. if assigned(hp2) then
  1076. begin
  1077. if hp2.nodetype<>statementn then
  1078. internalerror(2006110801);
  1079. while assigned(tstatementnode(hp2).next) do
  1080. hp2:=tstatementnode(hp2).next;
  1081. hp:=tstatementnode(hp2).statement;
  1082. end
  1083. else
  1084. begin
  1085. if report_errors then
  1086. CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
  1087. exit;
  1088. end;
  1089. end;
  1090. asn :
  1091. begin
  1092. { asn can't be assigned directly, it returns the value in a register instead
  1093. of reference. }
  1094. if not(gotsubscript or gotderef or gotvec) then
  1095. begin
  1096. if report_errors then
  1097. CGMessagePos(hp.fileinfo,errmsg);
  1098. exit;
  1099. end;
  1100. hp:=tunarynode(hp).left;
  1101. end;
  1102. subscriptn :
  1103. begin
  1104. { only check first (= outermost) subscriptn }
  1105. if not gotsubscript and
  1106. not(valid_packed in opts) and
  1107. is_packed_record_or_object(tsubscriptnode(hp).left.resultdef) and
  1108. ((tsubscriptnode(hp).vs.fieldoffset mod 8 <> 0) or
  1109. (is_ordinal(tsubscriptnode(hp).resultdef) and
  1110. not ispowerof2(tsubscriptnode(hp).resultdef.packedbitsize div 8,temp))) then
  1111. begin
  1112. if report_errors then
  1113. if (valid_property in opts) then
  1114. CGMessagePos(hp.fileinfo,parser_e_packed_element_no_loop)
  1115. else
  1116. CGMessagePos(hp.fileinfo,parser_e_packed_element_no_var_addr);
  1117. exit;
  1118. end;
  1119. gotsubscript:=true;
  1120. { loop counter? }
  1121. if not(Valid_Const in opts) and
  1122. (vo_is_loop_counter in tsubscriptnode(hp).vs.varoptions) then
  1123. begin
  1124. if report_errors then
  1125. CGMessage1(parser_e_illegal_assignment_to_count_var,tsubscriptnode(hp).vs.realname)
  1126. else
  1127. exit;
  1128. end;
  1129. { a class/interface access is an implicit }
  1130. { dereferencing }
  1131. hp:=tsubscriptnode(hp).left;
  1132. if is_class_or_interface_or_dispinterface_or_objc(hp.resultdef) then
  1133. gotderef:=true;
  1134. end;
  1135. muln,
  1136. divn,
  1137. andn,
  1138. xorn,
  1139. orn,
  1140. notn,
  1141. subn,
  1142. addn :
  1143. begin
  1144. { Allow operators on a pointer, or an integer
  1145. and a pointer typecast and deref has been found }
  1146. if ((hp.resultdef.typ=pointerdef) or
  1147. (is_integer(hp.resultdef) and gotpointer)) and
  1148. gotderef then
  1149. result:=true
  1150. else
  1151. { Temp strings are stored in memory, for compatibility with
  1152. delphi only }
  1153. if (m_delphi in current_settings.modeswitches) and
  1154. ((valid_addr in opts) or
  1155. (valid_const in opts)) and
  1156. (hp.resultdef.typ=stringdef) then
  1157. result:=true
  1158. else
  1159. if report_errors then
  1160. CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
  1161. exit;
  1162. end;
  1163. niln,
  1164. pointerconstn :
  1165. begin
  1166. { to support e.g. @tmypointer(0)^.data; see tests/tbs/tb0481 }
  1167. if gotderef then
  1168. result:=true
  1169. else
  1170. if report_errors then
  1171. CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr);
  1172. exit;
  1173. end;
  1174. ordconstn,
  1175. realconstn :
  1176. begin
  1177. { these constants will be passed by value }
  1178. if report_errors then
  1179. CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
  1180. exit;
  1181. end;
  1182. setconstn,
  1183. stringconstn,
  1184. guidconstn :
  1185. begin
  1186. { these constants will be passed by reference }
  1187. if valid_const in opts then
  1188. result:=true
  1189. else
  1190. if report_errors then
  1191. CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
  1192. exit;
  1193. end;
  1194. addrn :
  1195. begin
  1196. if gotderef then
  1197. result:=true
  1198. else
  1199. if report_errors then
  1200. CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr);
  1201. exit;
  1202. end;
  1203. calln :
  1204. begin
  1205. { check return type }
  1206. case hp.resultdef.typ of
  1207. arraydef :
  1208. begin
  1209. { dynamic arrays are allowed when there is also a
  1210. vec node }
  1211. if is_dynamic_array(hp.resultdef) and
  1212. gotvec then
  1213. begin
  1214. gotderef:=true;
  1215. gotpointer:=true;
  1216. end;
  1217. end;
  1218. pointerdef :
  1219. gotpointer:=true;
  1220. objectdef :
  1221. gotclass:=is_class_or_interface_or_dispinterface_or_objc(hp.resultdef);
  1222. recorddef, { handle record like class it needs a subscription }
  1223. classrefdef :
  1224. gotclass:=true;
  1225. stringdef :
  1226. gotstring:=true;
  1227. end;
  1228. { 1. if it returns a pointer and we've found a deref,
  1229. 2. if it returns a class or record and a subscription or with is found
  1230. 3. string is returned }
  1231. if (gotstring and gotvec) or
  1232. (gotpointer and gotderef) or
  1233. (gotclass and gotsubscript) then
  1234. result:=true
  1235. else
  1236. { Temp strings are stored in memory, for compatibility with
  1237. delphi only }
  1238. if (m_delphi in current_settings.modeswitches) and
  1239. (valid_addr in opts) and
  1240. (hp.resultdef.typ=stringdef) then
  1241. result:=true
  1242. else
  1243. if ([valid_const,valid_addr] * opts = [valid_const]) then
  1244. result:=true
  1245. else
  1246. if report_errors then
  1247. CGMessagePos(hp.fileinfo,errmsg);
  1248. exit;
  1249. end;
  1250. inlinen :
  1251. begin
  1252. if ((valid_const in opts) and
  1253. (tinlinenode(hp).inlinenumber in [in_typeof_x])) or
  1254. (tinlinenode(hp).inlinenumber in [in_unaligned_x]) then
  1255. result:=true
  1256. else
  1257. if report_errors then
  1258. CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
  1259. exit;
  1260. end;
  1261. dataconstn:
  1262. begin
  1263. { only created internally, so no additional checks necessary }
  1264. result:=true;
  1265. exit;
  1266. end;
  1267. loadn :
  1268. begin
  1269. case tloadnode(hp).symtableentry.typ of
  1270. absolutevarsym,
  1271. staticvarsym,
  1272. localvarsym,
  1273. paravarsym :
  1274. begin
  1275. { loop counter? }
  1276. if not(Valid_Const in opts) and
  1277. not gotderef and
  1278. (vo_is_loop_counter in tabstractvarsym(tloadnode(hp).symtableentry).varoptions) then
  1279. if report_errors then
  1280. CGMessage1(parser_e_illegal_assignment_to_count_var,tloadnode(hp).symtableentry.realname)
  1281. else
  1282. exit;
  1283. { read-only variable? }
  1284. if (tabstractvarsym(tloadnode(hp).symtableentry).varspez=vs_const) then
  1285. begin
  1286. { allow p^:= constructions with p is const parameter }
  1287. if gotderef or gotdynarray or (Valid_Const in opts) or
  1288. (nf_isinternal_ignoreconst in tloadnode(hp).flags) then
  1289. result:=true
  1290. else
  1291. if report_errors then
  1292. CGMessagePos(tloadnode(hp).fileinfo,type_e_no_assign_to_const);
  1293. exit;
  1294. end;
  1295. result:=true;
  1296. exit;
  1297. end;
  1298. procsym :
  1299. begin
  1300. if (Valid_Const in opts) then
  1301. result:=true
  1302. else
  1303. if report_errors then
  1304. CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
  1305. exit;
  1306. end;
  1307. labelsym :
  1308. begin
  1309. if (Valid_Addr in opts) then
  1310. result:=true
  1311. else
  1312. if report_errors then
  1313. CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
  1314. exit;
  1315. end;
  1316. constsym:
  1317. begin
  1318. if (tconstsym(tloadnode(hp).symtableentry).consttyp=constresourcestring) and
  1319. (valid_addr in opts) then
  1320. result:=true
  1321. else
  1322. if report_errors then
  1323. CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
  1324. exit;
  1325. end;
  1326. else
  1327. begin
  1328. if report_errors then
  1329. CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
  1330. exit;
  1331. end;
  1332. end;
  1333. end;
  1334. else
  1335. begin
  1336. if report_errors then
  1337. CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
  1338. exit;
  1339. end;
  1340. end;
  1341. end;
  1342. end;
  1343. function valid_for_var(p:tnode; report_errors: boolean):boolean;
  1344. begin
  1345. valid_for_var:=valid_for_assign(p,[],report_errors);
  1346. end;
  1347. function valid_for_formal_var(p : tnode; report_errors: boolean) : boolean;
  1348. begin
  1349. valid_for_formal_var:=valid_for_assign(p,[valid_void],report_errors);
  1350. end;
  1351. function valid_for_formal_const(p : tnode; report_errors: boolean) : boolean;
  1352. begin
  1353. valid_for_formal_const:=(p.resultdef.typ=formaldef) or
  1354. valid_for_assign(p,[valid_void,valid_const,valid_property],report_errors);
  1355. end;
  1356. function valid_for_assignment(p:tnode; report_errors: boolean):boolean;
  1357. begin
  1358. valid_for_assignment:=valid_for_assign(p,[valid_property,valid_packed],report_errors);
  1359. end;
  1360. function valid_for_loopvar(p:tnode; report_errors: boolean):boolean;
  1361. begin
  1362. valid_for_loopvar:=valid_for_assign(p,[valid_property],report_errors);
  1363. end;
  1364. function valid_for_addr(p : tnode; report_errors: boolean) : boolean;
  1365. begin
  1366. result:=valid_for_assign(p,[valid_const,valid_addr,valid_void],report_errors);
  1367. end;
  1368. procedure var_para_allowed(var eq:tequaltype;def_from,def_to:Tdef; fromnode: tnode);
  1369. begin
  1370. { Note: eq must be already valid, it will only be updated! }
  1371. case def_to.typ of
  1372. formaldef :
  1373. begin
  1374. { all types can be passed to a formaldef,
  1375. but it is not the prefered way }
  1376. if not is_constnode(fromnode) then
  1377. eq:=te_convert_l2
  1378. else
  1379. eq:=te_incompatible;
  1380. end;
  1381. orddef :
  1382. begin
  1383. { allows conversion from word to integer and
  1384. byte to shortint, but only for TP7 compatibility }
  1385. if (m_tp7 in current_settings.modeswitches) and
  1386. (def_from.typ=orddef) and
  1387. (def_from.size=def_to.size) then
  1388. eq:=te_convert_l1;
  1389. end;
  1390. arraydef :
  1391. begin
  1392. if is_open_array(def_to) then
  1393. begin
  1394. if is_dynamic_array(def_from) and
  1395. equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then
  1396. eq:=te_convert_l2
  1397. else
  1398. if equal_defs(def_from,tarraydef(def_to).elementdef) then
  1399. eq:=te_convert_l2;
  1400. end;
  1401. end;
  1402. pointerdef :
  1403. begin
  1404. { an implicit pointer conversion is allowed }
  1405. if (def_from.typ=pointerdef) then
  1406. eq:=te_convert_l1;
  1407. end;
  1408. stringdef :
  1409. begin
  1410. { all shortstrings are allowed, size is not important }
  1411. if is_shortstring(def_from) and
  1412. is_shortstring(def_to) then
  1413. eq:=te_equal;
  1414. end;
  1415. objectdef :
  1416. begin
  1417. { child objects can be also passed }
  1418. { in non-delphi mode, otherwise }
  1419. { they must match exactly, except }
  1420. { if they are objects }
  1421. if (def_from.typ=objectdef) and
  1422. (
  1423. (tobjectdef(def_from).objecttype=odt_object) and
  1424. (tobjectdef(def_to).objecttype=odt_object)
  1425. ) and
  1426. (tobjectdef(def_from).is_related(tobjectdef(def_to))) then
  1427. eq:=te_convert_l1;
  1428. end;
  1429. filedef :
  1430. begin
  1431. { an implicit file conversion is also allowed }
  1432. { from a typed file to an untyped one }
  1433. if (def_from.typ=filedef) and
  1434. (tfiledef(def_from).filetyp = ft_typed) and
  1435. (tfiledef(def_to).filetyp = ft_untyped) then
  1436. eq:=te_convert_l1;
  1437. end;
  1438. end;
  1439. end;
  1440. procedure para_allowed(var eq:tequaltype;p:tcallparanode;def_to:tdef);
  1441. var
  1442. acn: tarrayconstructornode;
  1443. tmpeq: tequaltype;
  1444. begin
  1445. { Note: eq must be already valid, it will only be updated! }
  1446. case def_to.typ of
  1447. formaldef :
  1448. begin
  1449. { all types can be passed to a formaldef }
  1450. eq:=te_equal;
  1451. end;
  1452. stringdef :
  1453. begin
  1454. { to support ansi/long/wide strings in a proper way }
  1455. { string and string[10] are assumed as equal }
  1456. { when searching the correct overloaded procedure }
  1457. if (p.resultdef.typ=stringdef) and
  1458. (tstringdef(def_to).stringtype=tstringdef(p.resultdef).stringtype) then
  1459. eq:=te_equal
  1460. else
  1461. { Passing a constant char to ansistring or shortstring or
  1462. a widechar to widestring then handle it as equal. }
  1463. if (p.left.nodetype=ordconstn) and
  1464. (
  1465. is_char(p.resultdef) and
  1466. (is_shortstring(def_to) or is_ansistring(def_to))
  1467. ) or
  1468. (
  1469. is_widechar(p.resultdef) and
  1470. (is_widestring(def_to) or is_unicodestring(def_to))
  1471. ) then
  1472. eq:=te_equal
  1473. end;
  1474. setdef :
  1475. begin
  1476. { set can also be a not yet converted array constructor }
  1477. if (p.resultdef.typ=arraydef) and
  1478. is_array_constructor(p.resultdef) and
  1479. not is_variant_array(p.resultdef) then
  1480. eq:=te_equal;
  1481. end;
  1482. procvardef :
  1483. begin
  1484. { in tp7 mode proc -> procvar is allowed }
  1485. if ((m_tp_procvar in current_settings.modeswitches) or
  1486. (m_mac_procvar in current_settings.modeswitches)) and
  1487. (p.left.nodetype=calln) and
  1488. (proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def_to),false)>=te_equal) then
  1489. eq:=te_equal
  1490. else
  1491. if (m_mac_procvar in current_settings.modeswitches) and
  1492. is_procvar_load(p.left) then
  1493. eq:=te_convert_l2;
  1494. end;
  1495. arraydef :
  1496. begin
  1497. { an arrayconstructor of proccalls may have to be converted to
  1498. an array of procvars }
  1499. if ((m_tp_procvar in current_settings.modeswitches) or
  1500. (m_mac_procvar in current_settings.modeswitches)) and
  1501. (tarraydef(def_to).elementdef.typ=procvardef) and
  1502. is_array_constructor(p.resultdef) and
  1503. not is_variant_array(p.resultdef) then
  1504. begin
  1505. acn:=tarrayconstructornode(p.left);
  1506. if assigned(acn.left) then
  1507. begin
  1508. eq:=te_exact;
  1509. while assigned(acn) and
  1510. (eq<>te_incompatible) do
  1511. begin
  1512. if (acn.left.nodetype=calln) then
  1513. tmpeq:=proc_to_procvar_equal(tprocdef(tcallnode(acn.left).procdefinition),tprocvardef(tarraydef(def_to).elementdef),false)
  1514. else
  1515. tmpeq:=compare_defs(acn.left.resultdef,tarraydef(def_to).elementdef,acn.left.nodetype);
  1516. if tmpeq<eq then
  1517. eq:=tmpeq;
  1518. acn:=tarrayconstructornode(acn.right);
  1519. end;
  1520. end
  1521. end;
  1522. end;
  1523. end;
  1524. end;
  1525. function allowenumop(nt:tnodetype):boolean;
  1526. begin
  1527. result:=(nt in [equaln,unequaln,ltn,lten,gtn,gten]) or
  1528. ((cs_allow_enum_calc in current_settings.localswitches) and
  1529. (nt in [addn,subn]));
  1530. end;
  1531. {****************************************************************************
  1532. TCallCandidates
  1533. ****************************************************************************}
  1534. constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall:boolean);
  1535. begin
  1536. if not assigned(sym) then
  1537. internalerror(200411015);
  1538. FOperator:=NOTOKEN;
  1539. FProcsym:=sym;
  1540. FProcsymtable:=st;
  1541. FParanode:=ppn;
  1542. create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall);
  1543. end;
  1544. constructor tcallcandidates.create_operator(op:ttoken;ppn:tnode);
  1545. begin
  1546. FOperator:=op;
  1547. FProcsym:=nil;
  1548. FProcsymtable:=nil;
  1549. FParanode:=ppn;
  1550. create_candidate_list(false,false,false);
  1551. end;
  1552. destructor tcallcandidates.destroy;
  1553. var
  1554. hpnext,
  1555. hp : pcandidate;
  1556. begin
  1557. hp:=FCandidateProcs;
  1558. while assigned(hp) do
  1559. begin
  1560. hpnext:=hp^.next;
  1561. dispose(hp);
  1562. hp:=hpnext;
  1563. end;
  1564. end;
  1565. procedure tcallcandidates.collect_overloads_in_class(ProcdefOverloadList:TFPObjectList);
  1566. var
  1567. j : integer;
  1568. pd : tprocdef;
  1569. srsym : tsym;
  1570. objdef : tobjectdef;
  1571. hashedid : THashedIDString;
  1572. hasoverload : boolean;
  1573. begin
  1574. objdef:=tobjectdef(fprocsym.owner.defowner);
  1575. hashedid.id:=fprocsym.name;
  1576. hasoverload:=false;
  1577. while assigned(objdef) do
  1578. begin
  1579. srsym:=tprocsym(objdef.symtable.FindWithHash(hashedid));
  1580. if assigned(srsym) then
  1581. begin
  1582. if (srsym.typ<>procsym) then
  1583. internalerror(200111022);
  1584. { add all definitions }
  1585. hasoverload:=false;
  1586. for j:=0 to tprocsym(srsym).ProcdefList.Count-1 do
  1587. begin
  1588. pd:=tprocdef(tprocsym(srsym).ProcdefList[j]);
  1589. if po_overload in pd.procoptions then
  1590. hasoverload:=true;
  1591. ProcdefOverloadList.Add(tprocsym(srsym).ProcdefList[j]);
  1592. end;
  1593. { when there is no explicit overload we stop searching }
  1594. if not hasoverload then
  1595. break;
  1596. end;
  1597. { next parent }
  1598. objdef:=objdef.childof;
  1599. end;
  1600. end;
  1601. procedure tcallcandidates.collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall: boolean);
  1602. var
  1603. j : integer;
  1604. pd : tprocdef;
  1605. srsymtable : TSymtable;
  1606. srsym : tsym;
  1607. checkstack : psymtablestackitem;
  1608. hashedid : THashedIDString;
  1609. hasoverload : boolean;
  1610. begin
  1611. { we search all overloaded operator definitions in the symtablestack. The found
  1612. entries are only added to the procs list and not the procsym, because
  1613. the list can change in every situation }
  1614. if FOperator=NOTOKEN then
  1615. begin
  1616. if not objcidcall then
  1617. hashedid.id:=FProcsym.name
  1618. else
  1619. hashedid.id:=class_helper_prefix+FProcsym.name;
  1620. end
  1621. else
  1622. hashedid.id:=overloaded_names[FOperator];
  1623. checkstack:=symtablestack.stack;
  1624. if assigned(FProcsymtable) then
  1625. begin
  1626. while assigned(checkstack) and
  1627. (checkstack^.symtable<>FProcsymtable) do
  1628. checkstack:=checkstack^.next;
  1629. end;
  1630. while assigned(checkstack) do
  1631. begin
  1632. srsymtable:=checkstack^.symtable;
  1633. if srsymtable.symtabletype in [localsymtable,staticsymtable,globalsymtable] then
  1634. begin
  1635. srsym:=tprocsym(srsymtable.FindWithHash(hashedid));
  1636. if assigned(srsym) and
  1637. (srsym.typ=procsym) then
  1638. begin
  1639. { Store first procsym found }
  1640. if not assigned(FProcsym) then
  1641. FProcsym:=tprocsym(srsym);
  1642. { add all definitions }
  1643. hasoverload:=false;
  1644. for j:=0 to tprocsym(srsym).ProcdefList.Count-1 do
  1645. begin
  1646. pd:=tprocdef(tprocsym(srsym).ProcdefList[j]);
  1647. if po_overload in pd.procoptions then
  1648. hasoverload:=true;
  1649. ProcdefOverloadList.Add(tprocsym(srsym).ProcdefList[j]);
  1650. end;
  1651. { when there is no explicit overload we stop searching,
  1652. except for Objective-C methods called via id }
  1653. if not hasoverload and
  1654. not objcidcall then
  1655. break;
  1656. end;
  1657. end;
  1658. checkstack:=checkstack^.next;
  1659. end;
  1660. end;
  1661. procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall:boolean);
  1662. var
  1663. j : integer;
  1664. pd : tprocdef;
  1665. hp : pcandidate;
  1666. pt : tcallparanode;
  1667. found : boolean;
  1668. contextobjdef : tobjectdef;
  1669. ProcdefOverloadList : TFPObjectList;
  1670. begin
  1671. FCandidateProcs:=nil;
  1672. { Find all available overloads for this procsym }
  1673. ProcdefOverloadList:=TFPObjectList.Create(false);
  1674. if not objcidcall and
  1675. (FOperator=NOTOKEN) and
  1676. (FProcsym.owner.symtabletype=objectsymtable) then
  1677. collect_overloads_in_class(ProcdefOverloadList)
  1678. else
  1679. collect_overloads_in_units(ProcdefOverloadList,objcidcall);
  1680. { determine length of parameter list.
  1681. for operators also enable the variant-operators if
  1682. a variant parameter is passed }
  1683. FParalength:=0;
  1684. FAllowVariant:=(FOperator=NOTOKEN);
  1685. pt:=tcallparanode(FParaNode);
  1686. while assigned(pt) do
  1687. begin
  1688. if (pt.resultdef.typ=variantdef) then
  1689. FAllowVariant:=true;
  1690. inc(FParalength);
  1691. pt:=tcallparanode(pt.right);
  1692. end;
  1693. { when the class passed is defined in this unit we
  1694. need to use the scope of that class. This is a trick
  1695. that can be used to access protected members in other
  1696. units. At least kylix supports it this way (PFV) }
  1697. if assigned(FProcSymtable) and
  1698. (
  1699. (FProcSymtable.symtabletype=ObjectSymtable) or
  1700. ((FProcSymtable.symtabletype=withsymtable) and
  1701. (FProcSymtable.defowner.typ=objectdef))
  1702. ) and
  1703. (FProcSymtable.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  1704. FProcSymtable.defowner.owner.iscurrentunit then
  1705. contextobjdef:=tobjectdef(FProcSymtable.defowner)
  1706. else
  1707. contextobjdef:=current_objectdef;
  1708. { Process all found overloads }
  1709. for j:=0 to ProcdefOverloadList.Count-1 do
  1710. begin
  1711. pd:=tprocdef(ProcdefOverloadList[j]);
  1712. { only when the # of parameter are supported by the procedure and
  1713. it is visible }
  1714. if (FParalength>=pd.minparacount) and
  1715. (
  1716. (
  1717. allowdefaultparas and
  1718. (
  1719. (FParalength<=pd.maxparacount) or
  1720. (po_varargs in pd.procoptions)
  1721. )
  1722. ) or
  1723. (
  1724. not allowdefaultparas and
  1725. (FParalength=pd.maxparacount)
  1726. )
  1727. ) and
  1728. (
  1729. ignorevisibility or
  1730. (pd.owner.symtabletype<>objectsymtable) or
  1731. is_visible_for_object(pd,contextobjdef)
  1732. ) then
  1733. begin
  1734. { don't add duplicates, only compare visible parameters for the user }
  1735. found:=false;
  1736. hp:=FCandidateProcs;
  1737. while assigned(hp) do
  1738. begin
  1739. if (compare_paras(hp^.data.paras,pd.paras,cp_value_equal_const,[cpo_ignorehidden])>=te_equal) and
  1740. (not(po_objc in pd.procoptions) or
  1741. (pd.messageinf.str^=hp^.data.messageinf.str^)) then
  1742. begin
  1743. found:=true;
  1744. break;
  1745. end;
  1746. hp:=hp^.next;
  1747. end;
  1748. if not found then
  1749. proc_add(fprocsym,pd,objcidcall);
  1750. end;
  1751. end;
  1752. ProcdefOverloadList.Free;
  1753. end;
  1754. function tcallcandidates.proc_add(ps:tprocsym;pd:tprocdef;objcidcall: boolean):pcandidate;
  1755. var
  1756. defaultparacnt : integer;
  1757. parentst : tsymtable;
  1758. begin
  1759. { generate new candidate entry }
  1760. new(result);
  1761. fillchar(result^,sizeof(tcandidate),0);
  1762. result^.data:=pd;
  1763. result^.next:=FCandidateProcs;
  1764. FCandidateProcs:=result;
  1765. inc(FProccnt);
  1766. { Find last parameter, skip all default parameters
  1767. that are not passed. Ignore this skipping for varargs }
  1768. result^.firstparaidx:=pd.paras.count-1;
  1769. if not(po_varargs in pd.procoptions) then
  1770. begin
  1771. { ignore hidden parameters }
  1772. while (result^.firstparaidx>=0) and (vo_is_hidden_para in tparavarsym(pd.paras[result^.firstparaidx]).varoptions) do
  1773. dec(result^.firstparaidx);
  1774. defaultparacnt:=pd.maxparacount-FParalength;
  1775. if defaultparacnt>0 then
  1776. begin
  1777. if defaultparacnt>result^.firstparaidx+1 then
  1778. internalerror(200401141);
  1779. dec(result^.firstparaidx,defaultparacnt);
  1780. end;
  1781. end;
  1782. { Give a small penalty for overloaded methods not in
  1783. defined the current class/unit }
  1784. parentst:=ps.owner;
  1785. { when calling Objective-C methods via id.method, then the found
  1786. procsym will be inside an arbitrary ObjectSymtable, and we don't
  1787. want togive the methods of that particular objcclass precedence over
  1788. other methods, so instead check against the symtable in which this
  1789. objcclass is defined }
  1790. if objcidcall then
  1791. parentst:=parentst.defowner.owner;
  1792. if (parentst<>pd.owner) then
  1793. result^.ordinal_distance:=result^.ordinal_distance+1.0;
  1794. end;
  1795. procedure tcallcandidates.list(all:boolean);
  1796. var
  1797. hp : pcandidate;
  1798. begin
  1799. hp:=FCandidateProcs;
  1800. while assigned(hp) do
  1801. begin
  1802. if all or
  1803. (not hp^.invalid) then
  1804. MessagePos1(hp^.data.fileinfo,sym_h_param_list,hp^.data.fullprocname(false));
  1805. hp:=hp^.next;
  1806. end;
  1807. end;
  1808. {$ifdef EXTDEBUG}
  1809. procedure tcallcandidates.dump_info(lvl:longint);
  1810. function ParaTreeStr(p:tcallparanode):string;
  1811. begin
  1812. result:='';
  1813. while assigned(p) do
  1814. begin
  1815. if result<>'' then
  1816. result:=','+result;
  1817. result:=p.resultdef.typename+result;
  1818. p:=tcallparanode(p.right);
  1819. end;
  1820. end;
  1821. var
  1822. hp : pcandidate;
  1823. i : integer;
  1824. currpara : tparavarsym;
  1825. begin
  1826. if not CheckVerbosity(lvl) then
  1827. exit;
  1828. Comment(lvl+V_LineInfo,'Overloaded callnode: '+FProcsym.name+'('+ParaTreeStr(tcallparanode(FParaNode))+')');
  1829. hp:=FCandidateProcs;
  1830. while assigned(hp) do
  1831. begin
  1832. Comment(lvl,' '+hp^.data.fullprocname(false));
  1833. if (hp^.invalid) then
  1834. Comment(lvl,' invalid')
  1835. else
  1836. begin
  1837. Comment(lvl,' ex: '+tostr(hp^.exact_count)+
  1838. ' eq: '+tostr(hp^.equal_count)+
  1839. ' l1: '+tostr(hp^.cl1_count)+
  1840. ' l2: '+tostr(hp^.cl2_count)+
  1841. ' l3: '+tostr(hp^.cl3_count)+
  1842. ' l4: '+tostr(hp^.cl4_count)+
  1843. ' l5: '+tostr(hp^.cl5_count)+
  1844. ' oper: '+tostr(hp^.coper_count)+
  1845. ' ord: '+realtostr(hp^.ordinal_distance));
  1846. { Print parameters in left-right order }
  1847. for i:=0 to hp^.data.paras.count-1 do
  1848. begin
  1849. currpara:=tparavarsym(hp^.data.paras[i]);
  1850. if not(vo_is_hidden_para in currpara.varoptions) then
  1851. Comment(lvl,' - '+currpara.vardef.typename+' : '+EqualTypeName[currpara.eqval]);
  1852. end;
  1853. end;
  1854. hp:=hp^.next;
  1855. end;
  1856. end;
  1857. {$endif EXTDEBUG}
  1858. procedure tcallcandidates.get_information;
  1859. var
  1860. hp : pcandidate;
  1861. currpara : tparavarsym;
  1862. paraidx : integer;
  1863. currparanr : byte;
  1864. rfh,rth : double;
  1865. objdef : tobjectdef;
  1866. def_from,
  1867. def_to : tdef;
  1868. currpt,
  1869. pt : tcallparanode;
  1870. eq : tequaltype;
  1871. convtype : tconverttype;
  1872. pdtemp,
  1873. pdoper : tprocdef;
  1874. releasecurrpt : boolean;
  1875. cdoptions : tcompare_defs_options;
  1876. n : tnode;
  1877. {$ifopt r+}{$define ena_r}{$r-}{$endif}
  1878. {$ifopt q+}{$define ena_q}{$q-}{$endif}
  1879. const
  1880. inf=1.0/0.0;
  1881. {$ifdef ena_r}{$r+}{$endif}
  1882. {$ifdef ena_q}{$q+}{$endif}
  1883. begin
  1884. cdoptions:=[cdo_check_operator];
  1885. if FAllowVariant then
  1886. include(cdoptions,cdo_allow_variant);
  1887. { process all procs }
  1888. hp:=FCandidateProcs;
  1889. while assigned(hp) do
  1890. begin
  1891. { We compare parameters in reverse order (right to left),
  1892. the firstpara is already pointing to the last parameter
  1893. were we need to start comparing }
  1894. currparanr:=FParalength;
  1895. paraidx:=hp^.firstparaidx;
  1896. while (paraidx>=0) and (vo_is_hidden_para in tparavarsym(hp^.data.paras[paraidx]).varoptions) do
  1897. dec(paraidx);
  1898. pt:=tcallparanode(FParaNode);
  1899. while assigned(pt) and (paraidx>=0) do
  1900. begin
  1901. currpara:=tparavarsym(hp^.data.paras[paraidx]);
  1902. { currpt can be changed from loadn to calln when a procvar
  1903. is passed. This is to prevent that the change is permanent }
  1904. currpt:=pt;
  1905. releasecurrpt:=false;
  1906. { retrieve current parameter definitions to compares }
  1907. eq:=te_incompatible;
  1908. def_from:=currpt.resultdef;
  1909. def_to:=currpara.vardef;
  1910. if not(assigned(def_from)) then
  1911. internalerror(200212091);
  1912. if not(
  1913. assigned(def_to) or
  1914. ((po_varargs in hp^.data.procoptions) and
  1915. (currparanr>hp^.data.minparacount))
  1916. ) then
  1917. internalerror(200212092);
  1918. { Convert tp procvars when not expecting a procvar }
  1919. if (currpt.left.resultdef.typ=procvardef) and
  1920. not(def_to.typ in [procvardef,formaldef]) and
  1921. { Only convert to call when there is no overload or the return type
  1922. is equal to the expected type. }
  1923. (
  1924. (count=1) or
  1925. equal_defs(tprocvardef(currpt.left.resultdef).returndef,def_to)
  1926. ) then
  1927. begin
  1928. releasecurrpt:=true;
  1929. currpt:=tcallparanode(pt.getcopy);
  1930. if maybe_call_procvar(currpt.left,true) then
  1931. begin
  1932. currpt.resultdef:=currpt.left.resultdef;
  1933. def_from:=currpt.left.resultdef;
  1934. end;
  1935. end;
  1936. { If we expect a procvar and the left is loadnode that
  1937. returns a procdef we need to find the correct overloaded
  1938. procdef that matches the expected procvar. The loadnode
  1939. temporary returned the first procdef (PFV) }
  1940. if (def_to.typ=procvardef) and
  1941. (currpt.left.nodetype=loadn) and
  1942. (currpt.left.resultdef.typ=procdef) then
  1943. begin
  1944. pdtemp:=tprocsym(Tloadnode(currpt.left).symtableentry).Find_procdef_byprocvardef(Tprocvardef(def_to));
  1945. if assigned(pdtemp) then
  1946. begin
  1947. tloadnode(currpt.left).setprocdef(pdtemp);
  1948. currpt.resultdef:=currpt.left.resultdef;
  1949. def_from:=currpt.left.resultdef;
  1950. end;
  1951. end;
  1952. { varargs are always equal, but not exact }
  1953. if (po_varargs in hp^.data.procoptions) and
  1954. (currparanr>hp^.data.minparacount) and
  1955. not is_array_of_const(def_from) and
  1956. not is_array_constructor(def_from) then
  1957. eq:=te_equal
  1958. else
  1959. { same definition -> exact }
  1960. if (def_from=def_to) then
  1961. eq:=te_exact
  1962. else
  1963. { for value and const parameters check if a integer is constant or
  1964. included in other integer -> equal and calc ordinal_distance }
  1965. if not(currpara.varspez in [vs_var,vs_out]) and
  1966. is_integer(def_from) and
  1967. is_integer(def_to) and
  1968. is_in_limit(def_from,def_to) then
  1969. begin
  1970. eq:=te_equal;
  1971. hp^.ordinal_distance:=hp^.ordinal_distance+
  1972. abs(bestreal(torddef(def_from).low)-bestreal(torddef(def_to).low));
  1973. rth:=bestreal(torddef(def_to).high);
  1974. rfh:=bestreal(torddef(def_from).high);
  1975. hp^.ordinal_distance:=hp^.ordinal_distance+abs(rth-rfh);
  1976. { Give wrong sign a small penalty, this is need to get a diffrence
  1977. from word->[longword,longint] }
  1978. if is_signed(def_from)<>is_signed(def_to) then
  1979. {$push}
  1980. {$r-}
  1981. {$q-}
  1982. hp^.ordinal_distance:=nextafter(hp^.ordinal_distance,inf);
  1983. {$pop}
  1984. end
  1985. else
  1986. { for value and const parameters check precision of real, give
  1987. penalty for loosing of precision. var and out parameters must match exactly }
  1988. if not(currpara.varspez in [vs_var,vs_out]) and
  1989. is_real(def_from) and
  1990. is_real(def_to) then
  1991. begin
  1992. eq:=te_equal;
  1993. if is_extended(def_to) then
  1994. rth:=4
  1995. else
  1996. if is_double (def_to) then
  1997. rth:=2
  1998. else
  1999. rth:=1;
  2000. if is_extended(def_from) then
  2001. rfh:=4
  2002. else
  2003. if is_double (def_from) then
  2004. rfh:=2
  2005. else
  2006. rfh:=1;
  2007. { penalty for shrinking of precision }
  2008. if rth<rfh then
  2009. rfh:=(rfh-rth)*16
  2010. else
  2011. rfh:=rth-rfh;
  2012. hp^.ordinal_distance:=hp^.ordinal_distance+rfh;
  2013. end
  2014. else
  2015. { related object parameters also need to determine the distance between the current
  2016. object and the object we are comparing with. var and out parameters must match exactly }
  2017. if not(currpara.varspez in [vs_var,vs_out]) and
  2018. (def_from.typ=objectdef) and
  2019. (def_to.typ=objectdef) and
  2020. (tobjectdef(def_from).objecttype=tobjectdef(def_to).objecttype) and
  2021. tobjectdef(def_from).is_related(tobjectdef(def_to)) then
  2022. begin
  2023. eq:=te_convert_l1;
  2024. objdef:=tobjectdef(def_from);
  2025. while assigned(objdef) do
  2026. begin
  2027. if objdef=def_to then
  2028. break;
  2029. hp^.ordinal_distance:=hp^.ordinal_distance+1;
  2030. objdef:=objdef.childof;
  2031. end;
  2032. end
  2033. { compare_defs_ext compares sets and array constructors very poorly because
  2034. it has too little information. So we do explicitly a detailed comparisation,
  2035. see also bug #11288 (FK)
  2036. }
  2037. else if (def_to.typ=setdef) and is_array_constructor(currpt.left.resultdef) then
  2038. begin
  2039. n:=currpt.left.getcopy;
  2040. arrayconstructor_to_set(n);
  2041. eq:=compare_defs_ext(n.resultdef,def_to,n.nodetype,convtype,pdoper,cdoptions);
  2042. n.free;
  2043. end
  2044. else
  2045. { generic type comparision }
  2046. begin
  2047. eq:=compare_defs_ext(def_from,def_to,currpt.left.nodetype,convtype,pdoper,cdoptions);
  2048. { when the types are not equal we need to check
  2049. some special case for parameter passing }
  2050. if (eq<te_equal) then
  2051. begin
  2052. if currpara.varspez in [vs_var,vs_out] then
  2053. begin
  2054. { para requires an equal type so the previous found
  2055. match was not good enough, reset to incompatible }
  2056. eq:=te_incompatible;
  2057. { var_para_allowed will return te_equal and te_convert_l1 to
  2058. make a difference for best matching }
  2059. var_para_allowed(eq,currpt.resultdef,currpara.vardef,currpt.left)
  2060. end
  2061. else
  2062. para_allowed(eq,currpt,def_to);
  2063. end;
  2064. end;
  2065. { univ parameters match if the size matches (don't override the
  2066. comparison result if it was ok, since a match based on the
  2067. "univ" character is the lowest possible match) }
  2068. if (eq=te_incompatible) and
  2069. currpara.univpara and
  2070. is_valid_univ_para_type(def_from) and
  2071. (def_from.size=def_to.size) then
  2072. eq:=te_convert_l5;
  2073. { when a procvar was changed to a call an exact match is
  2074. downgraded to equal. This way an overload call with the
  2075. procvar is choosen. See tb0471 (PFV) }
  2076. if (pt<>currpt) and (eq=te_exact) then
  2077. eq:=te_equal;
  2078. { increase correct counter }
  2079. case eq of
  2080. te_exact :
  2081. inc(hp^.exact_count);
  2082. te_equal :
  2083. inc(hp^.equal_count);
  2084. te_convert_l1 :
  2085. inc(hp^.cl1_count);
  2086. te_convert_l2 :
  2087. inc(hp^.cl2_count);
  2088. te_convert_l3 :
  2089. inc(hp^.cl3_count);
  2090. te_convert_l4 :
  2091. inc(hp^.cl4_count);
  2092. te_convert_l5 :
  2093. inc(hp^.cl5_count);
  2094. te_convert_operator :
  2095. inc(hp^.coper_count);
  2096. te_incompatible :
  2097. hp^.invalid:=true;
  2098. else
  2099. internalerror(200212072);
  2100. end;
  2101. { stop checking when an incompatible parameter is found }
  2102. if hp^.invalid then
  2103. begin
  2104. { store the current parameter info for
  2105. a nice error message when no procedure is found }
  2106. hp^.wrongparaidx:=paraidx;
  2107. hp^.wrongparanr:=currparanr;
  2108. break;
  2109. end;
  2110. {$ifdef EXTDEBUG}
  2111. { store equal in node tree for dump }
  2112. currpara.eqval:=eq;
  2113. {$endif EXTDEBUG}
  2114. { maybe release temp currpt }
  2115. if releasecurrpt then
  2116. currpt.free;
  2117. { next parameter in the call tree }
  2118. pt:=tcallparanode(pt.right);
  2119. { next parameter for definition, only goto next para
  2120. if we're out of the varargs }
  2121. if not(po_varargs in hp^.data.procoptions) or
  2122. (currparanr<=hp^.data.maxparacount) then
  2123. begin
  2124. { Ignore vs_hidden parameters }
  2125. repeat
  2126. dec(paraidx);
  2127. until (paraidx<0) or not(vo_is_hidden_para in tparavarsym(hp^.data.paras[paraidx]).varoptions);
  2128. end;
  2129. dec(currparanr);
  2130. end;
  2131. if not(hp^.invalid) and
  2132. (assigned(pt) or (paraidx>=0) or (currparanr<>0)) then
  2133. internalerror(200212141);
  2134. { next candidate }
  2135. hp:=hp^.next;
  2136. end;
  2137. end;
  2138. function get_variantequaltype(def: tdef): tvariantequaltype;
  2139. const
  2140. variantorddef_cl: array[tordtype] of tvariantequaltype =
  2141. (tve_incompatible,tve_byte,tve_word,tve_cardinal,tve_chari64,
  2142. tve_shortint,tve_smallint,tve_longint,tve_chari64,
  2143. tve_boolformal,tve_boolformal,tve_boolformal,tve_boolformal,tve_boolformal,
  2144. tve_chari64,tve_chari64,tve_dblcurrency);
  2145. { TODO: fixme for 128 bit floats }
  2146. variantfloatdef_cl: array[tfloattype] of tvariantequaltype =
  2147. (tve_single,tve_dblcurrency,tve_extended,tve_extended,
  2148. tve_dblcurrency,tve_dblcurrency,tve_extended);
  2149. variantstringdef_cl: array[tstringtype] of tvariantequaltype =
  2150. (tve_sstring,tve_astring,tve_astring,tve_wstring,tve_ustring);
  2151. begin
  2152. case def.typ of
  2153. orddef:
  2154. begin
  2155. result:=variantorddef_cl[torddef(def).ordtype];
  2156. end;
  2157. floatdef:
  2158. begin
  2159. result:=variantfloatdef_cl[tfloatdef(def).floattype];
  2160. end;
  2161. stringdef:
  2162. begin
  2163. result:=variantstringdef_cl[tstringdef(def).stringtype];
  2164. end;
  2165. formaldef:
  2166. begin
  2167. result:=tve_boolformal;
  2168. end;
  2169. else
  2170. begin
  2171. result:=tve_incompatible;
  2172. end;
  2173. end
  2174. end;
  2175. function is_better_candidate(currpd,bestpd:pcandidate):integer;
  2176. var
  2177. res : integer;
  2178. begin
  2179. {
  2180. Return values:
  2181. > 0 when currpd is better than bestpd
  2182. < 0 when bestpd is better than currpd
  2183. = 0 when both are equal
  2184. To choose the best candidate we use the following order:
  2185. - Incompatible flag
  2186. - (Smaller) Number of convert operator parameters.
  2187. - (Smaller) Number of convertlevel 2 parameters.
  2188. - (Smaller) Number of convertlevel 1 parameters.
  2189. - (Bigger) Number of exact parameters.
  2190. - (Smaller) Number of equal parameters.
  2191. - (Smaller) Total of ordinal distance. For example, the distance of a word
  2192. to a byte is 65535-255=65280.
  2193. }
  2194. if bestpd^.invalid then
  2195. begin
  2196. if currpd^.invalid then
  2197. res:=0
  2198. else
  2199. res:=1;
  2200. end
  2201. else
  2202. if currpd^.invalid then
  2203. res:=-1
  2204. else
  2205. begin
  2206. { less operator parameters? }
  2207. res:=(bestpd^.coper_count-currpd^.coper_count);
  2208. if (res=0) then
  2209. begin
  2210. { less cl5 parameters? }
  2211. res:=(bestpd^.cl5_count-currpd^.cl5_count);
  2212. if (res=0) then
  2213. begin
  2214. { less cl4 parameters? }
  2215. res:=(bestpd^.cl4_count-currpd^.cl4_count);
  2216. if (res=0) then
  2217. begin
  2218. { less cl3 parameters? }
  2219. res:=(bestpd^.cl3_count-currpd^.cl3_count);
  2220. if (res=0) then
  2221. begin
  2222. { less cl2 parameters? }
  2223. res:=(bestpd^.cl2_count-currpd^.cl2_count);
  2224. if (res=0) then
  2225. begin
  2226. { less cl1 parameters? }
  2227. res:=(bestpd^.cl1_count-currpd^.cl1_count);
  2228. if (res=0) then
  2229. begin
  2230. { more exact parameters? }
  2231. res:=(currpd^.exact_count-bestpd^.exact_count);
  2232. if (res=0) then
  2233. begin
  2234. { less equal parameters? }
  2235. res:=(bestpd^.equal_count-currpd^.equal_count);
  2236. if (res=0) then
  2237. begin
  2238. { smaller ordinal distance? }
  2239. if (currpd^.ordinal_distance<bestpd^.ordinal_distance) then
  2240. res:=1
  2241. else
  2242. if (currpd^.ordinal_distance>bestpd^.ordinal_distance) then
  2243. res:=-1
  2244. else
  2245. res:=0;
  2246. end;
  2247. end;
  2248. end;
  2249. end;
  2250. end;
  2251. end;
  2252. end;
  2253. end;
  2254. end;
  2255. is_better_candidate:=res;
  2256. end;
  2257. { Delphi precedence rules extracted from test programs. Only valid if passing
  2258. a variant parameter to overloaded procedures expecting exactly one parameter.
  2259. single > (char, currency, int64, shortstring, ansistring, widestring, extended, double)
  2260. double/currency > (char, int64, shortstring, ansistring, widestring, extended)
  2261. extended > (char, int64, shortstring, ansistring, widestring)
  2262. longint/cardinal > (int64, shortstring, ansistring, widestring, extended, double, single, char, currency)
  2263. smallint > (longint, int64, shortstring, ansistring, widestring, extended, double single, char, currency);
  2264. word > (longint, cardinal, int64, shortstring, ansistring, widestring, extended, double single, char, currency);
  2265. shortint > (longint, smallint, int64, shortstring, ansistring, widestring, extended, double, single, char, currency)
  2266. byte > (longint, cardinal, word, smallint, int64, shortstring, ansistring, widestring, extended, double, single, char, currency);
  2267. boolean/formal > (char, int64, shortstring, ansistring, widestring)
  2268. shortstring > (char, int64, ansistring, widestring)
  2269. ansistring > (char, int64, widestring)
  2270. widestring > (char, int64)
  2271. Relations not mentioned mean that they conflict: no decision possible }
  2272. function is_better_candidate_single_variant(currpd,bestpd:pcandidate):integer;
  2273. function calculate_relation(const currvcl, bestvcl, testvcl:
  2274. tvariantequaltype; const conflictvcls: tvariantequaltypes):integer;
  2275. begin
  2276. { if (bestvcl=conflictvcl) or
  2277. (currvcl=conflictvcl) then
  2278. result:=0
  2279. else if (bestvcl=testvcl) then
  2280. result:=-1
  2281. else result:=1 }
  2282. result:=1-2*ord(bestvcl=testvcl)+
  2283. ord(currvcl in conflictvcls)-ord(bestvcl in conflictvcls);
  2284. end;
  2285. function getfirstrealparaidx(pd: pcandidate): integer;
  2286. begin
  2287. { can be different for currpd and bestpd in case of overloaded }
  2288. { functions, e.g. lowercase():char and lowercase():shortstring }
  2289. { (depending on the calling convention and parameter order) }
  2290. result:=pd^.firstparaidx;
  2291. while (result>=0) and (vo_is_hidden_para in tparavarsym(pd^.data.paras[result]).varoptions) do
  2292. dec(result);
  2293. if (vo_is_hidden_para in tparavarsym(pd^.data.paras[result]).varoptions) then
  2294. internalerror(2006122803);
  2295. end;
  2296. var
  2297. currpara, bestpara: tparavarsym;
  2298. currvcl, bestvcl: tvariantequaltype;
  2299. begin
  2300. {
  2301. Return values:
  2302. > 0 when currpd is better than bestpd
  2303. < 0 when bestpd is better than currpd
  2304. = 0 when both are equal
  2305. }
  2306. currpara:=tparavarsym(currpd^.data.paras[getfirstrealparaidx(currpd)]);
  2307. bestpara:=tparavarsym(bestpd^.data.paras[getfirstrealparaidx(bestpd)]);
  2308. { if one of the parameters is a regular variant, fall back to the }
  2309. { default algorithm }
  2310. if (currpara.vardef.typ = variantdef) or
  2311. (bestpara.vardef.typ = variantdef) then
  2312. begin
  2313. result:=is_better_candidate(currpd,bestpd);
  2314. exit;
  2315. end;
  2316. currvcl:=get_variantequaltype(currpara.vardef);
  2317. bestvcl:=get_variantequaltype(bestpara.vardef);
  2318. { sanity check }
  2319. result:=-5;
  2320. { if both are the same, there is a conflict }
  2321. if (currvcl=bestvcl) then
  2322. result:=0
  2323. { if one of the two cannot be used as variant, the other is better }
  2324. else if (bestvcl=tve_incompatible) then
  2325. result:=1
  2326. else if (currvcl=tve_incompatible) then
  2327. result:=-1
  2328. { boolean and formal are better than chari64str, but conflict with }
  2329. { everything else }
  2330. else if (currvcl=tve_boolformal) or
  2331. (bestvcl=tve_boolformal) then
  2332. if (currvcl=tve_boolformal) then
  2333. result:=ord(bestvcl in [tve_chari64,tve_sstring,tve_astring,tve_wstring,tve_ustring])
  2334. else
  2335. result:=-ord(currvcl in [tve_chari64,tve_sstring,tve_astring,tve_wstring,tve_ustring])
  2336. { byte is better than everything else (we assume both aren't byte, }
  2337. { since there's only one parameter and that one can't be the same) }
  2338. else if (currvcl=tve_byte) or
  2339. (bestvcl=tve_byte) then
  2340. result:=calculate_relation(currvcl,bestvcl,tve_byte,[tve_shortint])
  2341. { shortint conflicts with word and cardinal, but is better than }
  2342. { everything else but byte (which has already been handled) }
  2343. else if (currvcl=tve_shortint) or
  2344. (bestvcl=tve_shortint) then
  2345. result:=calculate_relation(currvcl,bestvcl,tve_shortint,[tve_word, tve_cardinal])
  2346. { word conflicts with smallint, but is better than everything else }
  2347. { but shortint and byte (which has already been handled) }
  2348. else if (currvcl=tve_word) or
  2349. (bestvcl=tve_word) then
  2350. result:=calculate_relation(currvcl,bestvcl,tve_word,[tve_smallint])
  2351. { smallint conflicts with cardinal, but is better than everything }
  2352. { which has not yet been tested }
  2353. else if (currvcl=tve_smallint) or
  2354. (bestvcl=tve_smallint) then
  2355. result:=calculate_relation(currvcl,bestvcl,tve_smallint,[tve_cardinal])
  2356. { cardinal conflicts with each longint and is better than everything }
  2357. { which has not yet been tested }
  2358. else if (currvcl=tve_cardinal) or
  2359. (bestvcl=tve_cardinal) then
  2360. result:=calculate_relation(currvcl,bestvcl,tve_cardinal,[tve_longint])
  2361. { longint is better than everything which has not yet been tested }
  2362. else if (currvcl=tve_longint) or
  2363. (bestvcl=tve_longint) then
  2364. { if bestvcl=tve_longint then
  2365. result:=-1
  2366. else
  2367. result:=1 }
  2368. result:=1-2*ord(bestvcl=tve_longint)
  2369. { single is better than everything left }
  2370. else if (currvcl=tve_single) or
  2371. (bestvcl=tve_single) then
  2372. result:=1-2*ord(bestvcl=tve_single)
  2373. { double/comp/currency are better than everything left, and conflict }
  2374. { with each other (but that's already tested) }
  2375. else if (currvcl=tve_dblcurrency) or
  2376. (bestvcl=tve_dblcurrency) then
  2377. result:=1-2*ord(bestvcl=tve_dblcurrency)
  2378. { extended is better than everything left }
  2379. else if (currvcl=tve_extended) or
  2380. (bestvcl=tve_extended) then
  2381. result:=1-2*ord(bestvcl=tve_extended)
  2382. { shortstring is better than everything left }
  2383. else if (currvcl=tve_sstring) or
  2384. (bestvcl=tve_sstring) then
  2385. result:=1-2*ord(bestvcl=tve_sstring)
  2386. { ansistring is better than everything left }
  2387. else if (currvcl=tve_astring) or
  2388. (bestvcl=tve_astring) then
  2389. result:=1-2*ord(bestvcl=tve_astring)
  2390. { widestring is better than everything left }
  2391. else if (currvcl=tve_wstring) or
  2392. (bestvcl=tve_wstring) then
  2393. result:=1-2*ord(bestvcl=tve_wstring)
  2394. { unicodestring is better than everything left }
  2395. else if (currvcl=tve_ustring) or
  2396. (bestvcl=tve_ustring) then
  2397. result:=1-2*ord(bestvcl=tve_ustring);
  2398. { all possibilities should have been checked now }
  2399. if (result=-5) then
  2400. internalerror(2006122805);
  2401. end;
  2402. function tcallcandidates.choose_best(var bestpd:tabstractprocdef; singlevariant: boolean):integer;
  2403. var
  2404. besthpstart,
  2405. hp : pcandidate;
  2406. cntpd,
  2407. res : integer;
  2408. begin
  2409. {
  2410. Returns the number of candidates left and the
  2411. first candidate is returned in pdbest
  2412. }
  2413. { Setup the first procdef as best, only count it as a result
  2414. when it is valid }
  2415. bestpd:=FCandidateProcs^.data;
  2416. if FCandidateProcs^.invalid then
  2417. cntpd:=0
  2418. else
  2419. cntpd:=1;
  2420. if assigned(FCandidateProcs^.next) then
  2421. begin
  2422. besthpstart:=FCandidateProcs;
  2423. hp:=FCandidateProcs^.next;
  2424. while assigned(hp) do
  2425. begin
  2426. if not singlevariant then
  2427. res:=is_better_candidate(hp,besthpstart)
  2428. else
  2429. res:=is_better_candidate_single_variant(hp,besthpstart);
  2430. if (res>0) then
  2431. begin
  2432. { hp is better, flag all procs to be incompatible }
  2433. while (besthpstart<>hp) do
  2434. begin
  2435. besthpstart^.invalid:=true;
  2436. besthpstart:=besthpstart^.next;
  2437. end;
  2438. { besthpstart is already set to hp }
  2439. bestpd:=besthpstart^.data;
  2440. cntpd:=1;
  2441. end
  2442. else
  2443. if (res<0) then
  2444. begin
  2445. { besthpstart is better, flag current hp to be incompatible }
  2446. hp^.invalid:=true;
  2447. end
  2448. else
  2449. begin
  2450. { res=0, both are valid }
  2451. if not hp^.invalid then
  2452. inc(cntpd);
  2453. end;
  2454. hp:=hp^.next;
  2455. end;
  2456. end;
  2457. result:=cntpd;
  2458. end;
  2459. procedure tcallcandidates.find_wrong_para;
  2460. var
  2461. currparanr : smallint;
  2462. hp : pcandidate;
  2463. pt : tcallparanode;
  2464. wrongpara : tparavarsym;
  2465. begin
  2466. { Only process the first overloaded procdef }
  2467. hp:=FCandidateProcs;
  2468. { Find callparanode corresponding to the argument }
  2469. pt:=tcallparanode(FParanode);
  2470. currparanr:=FParalength;
  2471. while assigned(pt) and
  2472. (currparanr>hp^.wrongparanr) do
  2473. begin
  2474. pt:=tcallparanode(pt.right);
  2475. dec(currparanr);
  2476. end;
  2477. if (currparanr<>hp^.wrongparanr) or
  2478. not assigned(pt) then
  2479. internalerror(200212094);
  2480. { Show error message, when it was a var or out parameter
  2481. guess that it is a missing typeconv }
  2482. wrongpara:=tparavarsym(hp^.data.paras[hp^.wrongparaidx]);
  2483. if wrongpara.varspez in [vs_var,vs_out] then
  2484. begin
  2485. { Maybe passing the correct type but passing a const to var parameter }
  2486. if (compare_defs(pt.resultdef,wrongpara.vardef,pt.nodetype)<>te_incompatible) and
  2487. not valid_for_var(pt.left,true) then
  2488. CGMessagePos(pt.left.fileinfo,type_e_variable_id_expected)
  2489. else
  2490. CGMessagePos3(pt.left.fileinfo,parser_e_call_by_ref_without_typeconv,tostr(hp^.wrongparanr),
  2491. FullTypeName(pt.left.resultdef,wrongpara.vardef),
  2492. FullTypeName(wrongpara.vardef,pt.left.resultdef))
  2493. end
  2494. else
  2495. CGMessagePos3(pt.left.fileinfo,type_e_wrong_parameter_type,tostr(hp^.wrongparanr),
  2496. FullTypeName(pt.left.resultdef,wrongpara.vardef),
  2497. FullTypeName(wrongpara.vardef,pt.left.resultdef));
  2498. end;
  2499. procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring);
  2500. begin
  2501. if not assigned(srsym) then
  2502. internalerror(200602051);
  2503. if sp_hint_deprecated in symoptions then
  2504. if (sp_has_deprecated_msg in symoptions) and (deprecatedmsg <> nil) then
  2505. Message2(sym_w_deprecated_symbol_with_msg,srsym.realname,deprecatedmsg^)
  2506. else
  2507. Message1(sym_w_deprecated_symbol,srsym.realname);
  2508. if sp_hint_experimental in symoptions then
  2509. Message1(sym_w_experimental_symbol,srsym.realname);
  2510. if sp_hint_platform in symoptions then
  2511. Message1(sym_w_non_portable_symbol,srsym.realname);
  2512. if sp_hint_library in symoptions then
  2513. Message1(sym_w_library_symbol,srsym.realname);
  2514. if sp_hint_unimplemented in symoptions then
  2515. Message1(sym_w_non_implemented_symbol,srsym.realname);
  2516. end;
  2517. procedure check_ranges(const location: tfileposinfo; source: tnode; destdef: tdef);
  2518. begin
  2519. if not(cs_check_ordinal_size in current_settings.localswitches) then
  2520. exit;
  2521. { check if the assignment may cause a range check error }
  2522. { if its not explicit, and only if the values are }
  2523. { ordinals, enumdef and floatdef }
  2524. if assigned(destdef) and
  2525. (destdef.typ in [enumdef,orddef,floatdef]) and
  2526. not is_boolean(destdef) and
  2527. assigned(source.resultdef) and
  2528. (source.resultdef.typ in [enumdef,orddef,floatdef]) and
  2529. not is_boolean(source.resultdef) and
  2530. not is_constrealnode(source) then
  2531. begin
  2532. if ((destdef.size < source.resultdef.size) and
  2533. { s80real and sc80real have a different size but the same precision }
  2534. not((destdef.typ=floatdef) and
  2535. (source.resultdef.typ=floatdef) and
  2536. (tfloatdef(source.resultdef).floattype in [s80real,sc80real]) and
  2537. (tfloatdef(destdef).floattype in [s80real,sc80real]))) or
  2538. ((destdef.typ<>floatdef) and
  2539. (source.resultdef.typ<>floatdef) and
  2540. not is_in_limit(source.resultdef,destdef)) then
  2541. begin
  2542. if (cs_check_range in current_settings.localswitches) then
  2543. MessagePos(location,type_w_smaller_possible_range_check)
  2544. else
  2545. MessagePos(location,type_h_smaller_possible_range_check);
  2546. end;
  2547. end;
  2548. end;
  2549. end.