htypechk.pas 98 KB

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