htypechk.pas 97 KB

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