htypechk.pas 100 KB

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