tccal.pas 53 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 by Florian Klaempfl
  4. Type checking and register allocation for call nodes
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. {$ifdef FPC}
  19. {$goto on}
  20. {$endif FPC}
  21. unit tccal;
  22. interface
  23. uses
  24. symtable,tree;
  25. procedure gen_high_tree(p:ptree;openstring:boolean);
  26. procedure firstcallparan(var p : ptree;defcoll : pparaitem;do_count : boolean);
  27. procedure firstcalln(var p : ptree);
  28. procedure firstprocinline(var p : ptree);
  29. implementation
  30. uses
  31. globtype,systems,
  32. cobjects,verbose,globals,
  33. symconst,aasm,types,
  34. htypechk,pass_1,cpubase
  35. {$ifdef newcg}
  36. ,cgbase
  37. ,tgobj
  38. {$else newcg}
  39. ,hcodegen
  40. {$ifdef i386}
  41. ,tgeni386
  42. {$endif}
  43. {$ifdef m68k}
  44. ,tgen68k
  45. {$endif m68k}
  46. {$endif newcg}
  47. ;
  48. {*****************************************************************************
  49. FirstCallParaN
  50. *****************************************************************************}
  51. procedure gen_high_tree(p:ptree;openstring:boolean);
  52. var
  53. len : longint;
  54. st : psymtable;
  55. loadconst : boolean;
  56. begin
  57. if assigned(p^.hightree) then
  58. exit;
  59. len:=-1;
  60. loadconst:=true;
  61. case p^.left^.resulttype^.deftype of
  62. arraydef :
  63. begin
  64. if is_open_array(p^.left^.resulttype) or
  65. is_array_of_const(p^.left^.resulttype) then
  66. begin
  67. st:=p^.left^.symtable;
  68. getsymonlyin(st,'high'+pvarsym(p^.left^.symtableentry)^.name);
  69. p^.hightree:=genloadnode(pvarsym(srsym),st);
  70. loadconst:=false;
  71. end
  72. else
  73. begin
  74. { this is an empty constructor }
  75. len:=parraydef(p^.left^.resulttype)^.highrange-
  76. parraydef(p^.left^.resulttype)^.lowrange;
  77. end;
  78. end;
  79. stringdef :
  80. begin
  81. if openstring then
  82. begin
  83. if is_open_string(p^.left^.resulttype) then
  84. begin
  85. st:=p^.left^.symtable;
  86. getsymonlyin(st,'high'+pvarsym(p^.left^.symtableentry)^.name);
  87. p^.hightree:=genloadnode(pvarsym(srsym),st);
  88. loadconst:=false;
  89. end
  90. else
  91. len:=pstringdef(p^.left^.resulttype)^.len;
  92. end
  93. else
  94. { passing a string to an array of char }
  95. begin
  96. if (p^.left^.treetype=stringconstn) then
  97. begin
  98. len:=str_length(p^.left);
  99. if len>0 then
  100. dec(len);
  101. end
  102. else
  103. begin
  104. p^.hightree:=gennode(subn,geninlinenode(in_length_string,false,getcopy(p^.left)),
  105. genordinalconstnode(1,s32bitdef));
  106. firstpass(p^.hightree);
  107. p^.hightree:=gentypeconvnode(p^.hightree,s32bitdef);
  108. loadconst:=false;
  109. end;
  110. end;
  111. end;
  112. else
  113. len:=0;
  114. end;
  115. if loadconst then
  116. p^.hightree:=genordinalconstnode(len,s32bitdef);
  117. firstpass(p^.hightree);
  118. end;
  119. procedure firstcallparan(var p : ptree;defcoll : pparaitem;do_count : boolean);
  120. var
  121. old_get_para_resulttype : boolean;
  122. old_array_constructor : boolean;
  123. oldtype : pdef;
  124. {$ifdef extdebug}
  125. store_count_ref : boolean;
  126. {$endif def extdebug}
  127. {convtyp : tconverttype;}
  128. begin
  129. inc(parsing_para_level);
  130. {$ifdef extdebug}
  131. if do_count then
  132. begin
  133. store_count_ref:=count_ref;
  134. count_ref:=true;
  135. end;
  136. {$endif def extdebug}
  137. if assigned(p^.right) then
  138. begin
  139. if defcoll=nil then
  140. firstcallparan(p^.right,nil,do_count)
  141. else
  142. firstcallparan(p^.right,pparaitem(defcoll^.next),do_count);
  143. p^.registers32:=p^.right^.registers32;
  144. p^.registersfpu:=p^.right^.registersfpu;
  145. {$ifdef SUPPORT_MMX}
  146. p^.registersmmx:=p^.right^.registersmmx;
  147. {$endif}
  148. end;
  149. if defcoll=nil then
  150. begin
  151. old_array_constructor:=allow_array_constructor;
  152. old_get_para_resulttype:=get_para_resulttype;
  153. get_para_resulttype:=true;
  154. allow_array_constructor:=true;
  155. firstpass(p^.left);
  156. get_para_resulttype:=old_get_para_resulttype;
  157. allow_array_constructor:=old_array_constructor;
  158. if codegenerror then
  159. begin
  160. dec(parsing_para_level);
  161. exit;
  162. end;
  163. p^.resulttype:=p^.left^.resulttype;
  164. end
  165. { if we know the routine which is called, then the type }
  166. { conversions are inserted }
  167. else
  168. begin
  169. { Do we need arrayconstructor -> set conversion, then insert
  170. it here before the arrayconstructor node breaks the tree
  171. with its conversions of enum->ord }
  172. if (p^.left^.treetype=arrayconstructn) and
  173. (defcoll^.paratype.def^.deftype=setdef) then
  174. p^.left:=gentypeconvnode(p^.left,defcoll^.paratype.def);
  175. { set some settings needed for arrayconstructor }
  176. if is_array_constructor(p^.left^.resulttype) then
  177. begin
  178. if is_array_of_const(defcoll^.paratype.def) then
  179. begin
  180. if assigned(aktcallprocsym) and
  181. (pocall_cdecl in aktcallprocsym^.definition^.proccalloptions) and
  182. (po_external in aktcallprocsym^.definition^.procoptions) then
  183. p^.left^.cargs:=true;
  184. { force variant array }
  185. p^.left^.forcevaria:=true;
  186. end
  187. else
  188. begin
  189. p^.left^.novariaallowed:=true;
  190. p^.left^.constructdef:=parraydef(defcoll^.paratype.def)^.elementtype.def;
  191. end;
  192. end;
  193. if do_count then
  194. begin
  195. { not completly proper, but avoids some warnings }
  196. if (defcoll^.paratyp=vs_var) then
  197. set_funcret_is_valid(p^.left);
  198. { protected has nothing to do with read/write
  199. if (defcoll^.paratyp=vs_var) then
  200. test_protected(p^.left);
  201. }
  202. { set_varstate(p^.left,defcoll^.paratyp<>vs_var);
  203. must only be done after typeconv PM }
  204. { only process typeconvn and arrayconstructn, else it will
  205. break other trees }
  206. { But this is need to get correct varstate !! PM }
  207. old_array_constructor:=allow_array_constructor;
  208. old_get_para_resulttype:=get_para_resulttype;
  209. allow_array_constructor:=true;
  210. get_para_resulttype:=false;
  211. if (p^.left^.treetype in [arrayconstructn,typeconvn]) then
  212. firstpass(p^.left);
  213. if not assigned(p^.resulttype) then
  214. p^.resulttype:=p^.left^.resulttype;
  215. get_para_resulttype:=old_get_para_resulttype;
  216. allow_array_constructor:=old_array_constructor;
  217. end;
  218. { check if local proc/func is assigned to procvar }
  219. if p^.left^.resulttype^.deftype=procvardef then
  220. test_local_to_procvar(pprocvardef(p^.left^.resulttype),defcoll^.paratype.def);
  221. { property is not allowed as var parameter }
  222. if (defcoll^.paratyp in [vs_out,vs_var]) and
  223. (p^.left^.isproperty) then
  224. CGMessagePos(p^.left^.fileinfo,type_e_argument_cant_be_assigned);
  225. { generate the high() value tree }
  226. if push_high_param(defcoll^.paratype.def) then
  227. gen_high_tree(p,is_open_string(defcoll^.paratype.def));
  228. if not(is_shortstring(p^.left^.resulttype) and
  229. is_shortstring(defcoll^.paratype.def)) and
  230. (defcoll^.paratype.def^.deftype<>formaldef) then
  231. begin
  232. if (defcoll^.paratyp in [vs_var,vs_out]) and
  233. { allows conversion from word to integer and
  234. byte to shortint }
  235. (not(
  236. (p^.left^.resulttype^.deftype=orddef) and
  237. (defcoll^.paratype.def^.deftype=orddef) and
  238. (p^.left^.resulttype^.size=defcoll^.paratype.def^.size)
  239. ) and
  240. { an implicit pointer conversion is allowed }
  241. not(
  242. (p^.left^.resulttype^.deftype=pointerdef) and
  243. (defcoll^.paratype.def^.deftype=pointerdef)
  244. ) and
  245. { child classes can be also passed }
  246. not(
  247. (p^.left^.resulttype^.deftype=objectdef) and
  248. (defcoll^.paratype.def^.deftype=objectdef) and
  249. pobjectdef(p^.left^.resulttype)^.is_related(pobjectdef(defcoll^.paratype.def))
  250. ) and
  251. { passing a single element to a openarray of the same type }
  252. not(
  253. (is_open_array(defcoll^.paratype.def) and
  254. is_equal(parraydef(defcoll^.paratype.def)^.elementtype.def,p^.left^.resulttype))
  255. ) and
  256. { an implicit file conversion is also allowed }
  257. { from a typed file to an untyped one }
  258. not(
  259. (p^.left^.resulttype^.deftype=filedef) and
  260. (defcoll^.paratype.def^.deftype=filedef) and
  261. (pfiledef(defcoll^.paratype.def)^.filetyp = ft_untyped) and
  262. (pfiledef(p^.left^.resulttype)^.filetyp = ft_typed)
  263. ) and
  264. not(is_equal(p^.left^.resulttype,defcoll^.paratype.def))) then
  265. begin
  266. CGMessagePos2(p^.left^.fileinfo,parser_e_call_by_ref_without_typeconv,
  267. p^.left^.resulttype^.typename,defcoll^.paratype.def^.typename);
  268. end;
  269. { Process open parameters }
  270. if push_high_param(defcoll^.paratype.def) then
  271. begin
  272. { insert type conv but hold the ranges of the array }
  273. oldtype:=p^.left^.resulttype;
  274. p^.left:=gentypeconvnode(p^.left,defcoll^.paratype.def);
  275. firstpass(p^.left);
  276. p^.left^.resulttype:=oldtype;
  277. end
  278. else
  279. begin
  280. p^.left:=gentypeconvnode(p^.left,defcoll^.paratype.def);
  281. firstpass(p^.left);
  282. end;
  283. if codegenerror then
  284. begin
  285. dec(parsing_para_level);
  286. exit;
  287. end;
  288. end;
  289. { check var strings }
  290. if (cs_strict_var_strings in aktlocalswitches) and
  291. is_shortstring(p^.left^.resulttype) and
  292. is_shortstring(defcoll^.paratype.def) and
  293. (defcoll^.paratyp in [vs_out,vs_var]) and
  294. not(is_open_string(defcoll^.paratype.def)) and
  295. not(is_equal(p^.left^.resulttype,defcoll^.paratype.def)) then
  296. begin
  297. aktfilepos:=p^.left^.fileinfo;
  298. CGMessage(type_e_strict_var_string_violation);
  299. end;
  300. { Variablen for call by reference may not be copied }
  301. { into a register }
  302. { is this usefull here ? }
  303. { this was missing in formal parameter list }
  304. if (defcoll^.paratype.def=pdef(cformaldef)) then
  305. begin
  306. if defcoll^.paratyp=vs_var then
  307. begin
  308. if not valid_for_formal_var(p^.left) then
  309. begin
  310. aktfilepos:=p^.left^.fileinfo;
  311. CGMessage(parser_e_illegal_parameter_list);
  312. end;
  313. end;
  314. if defcoll^.paratyp=vs_const then
  315. begin
  316. if not valid_for_formal_const(p^.left) then
  317. begin
  318. aktfilepos:=p^.left^.fileinfo;
  319. CGMessage(parser_e_illegal_parameter_list);
  320. end;
  321. end;
  322. end;
  323. if defcoll^.paratyp in [vs_var,vs_const] then
  324. begin
  325. { Causes problems with const ansistrings if also }
  326. { done for vs_const (JM) }
  327. if defcoll^.paratyp = vs_var then
  328. set_unique(p^.left);
  329. make_not_regable(p^.left);
  330. end;
  331. { ansistrings out paramaters doesn't need to be }
  332. { unique, they are finalized }
  333. if defcoll^.paratyp=vs_out then
  334. make_not_regable(p^.left);
  335. if do_count then
  336. set_varstate(p^.left,defcoll^.paratyp <> vs_var);
  337. { must only be done after typeconv PM }
  338. p^.resulttype:=defcoll^.paratype.def;
  339. end;
  340. if p^.left^.registers32>p^.registers32 then
  341. p^.registers32:=p^.left^.registers32;
  342. if p^.left^.registersfpu>p^.registersfpu then
  343. p^.registersfpu:=p^.left^.registersfpu;
  344. {$ifdef SUPPORT_MMX}
  345. if p^.left^.registersmmx>p^.registersmmx then
  346. p^.registersmmx:=p^.left^.registersmmx;
  347. {$endif SUPPORT_MMX}
  348. dec(parsing_para_level);
  349. {$ifdef extdebug}
  350. if do_count then
  351. count_ref:=store_count_ref;
  352. {$endif def extdebug}
  353. end;
  354. {*****************************************************************************
  355. FirstCallN
  356. *****************************************************************************}
  357. procedure firstcalln(var p : ptree);
  358. type
  359. pprocdefcoll = ^tprocdefcoll;
  360. tprocdefcoll = record
  361. data : pprocdef;
  362. nextpara : pparaitem;
  363. firstpara : pparaitem;
  364. next : pprocdefcoll;
  365. end;
  366. var
  367. hp,procs,hp2 : pprocdefcoll;
  368. pd : pprocdef;
  369. oldcallprocsym : pprocsym;
  370. def_from,def_to,conv_to : pdef;
  371. hpt,pt,inlinecode : ptree;
  372. exactmatch,inlined : boolean;
  373. paralength,lastpara : longint;
  374. lastparatype : pdef;
  375. pdc : pparaitem;
  376. {$ifdef TEST_PROCSYMS}
  377. nextprocsym : pprocsym;
  378. symt : psymtable;
  379. {$endif TEST_PROCSYMS}
  380. { only Dummy }
  381. hcvt : tconverttype;
  382. {$ifdef m68k}
  383. regi : tregister;
  384. {$endif}
  385. method_must_be_valid : boolean;
  386. label
  387. errorexit;
  388. { check if the resulttype from tree p is equal with def, needed
  389. for stringconstn and formaldef }
  390. function is_equal(p:ptree;def:pdef) : boolean;
  391. begin
  392. { safety check }
  393. if not (assigned(def) or assigned(p^.resulttype)) then
  394. begin
  395. is_equal:=false;
  396. exit;
  397. end;
  398. { all types can be passed to a formaldef }
  399. is_equal:=(def^.deftype=formaldef) or
  400. (types.is_equal(p^.resulttype,def))
  401. { to support ansi/long/wide strings in a proper way }
  402. { string and string[10] are assumed as equal }
  403. { when searching the correct overloaded procedure }
  404. or
  405. (
  406. (def^.deftype=stringdef) and (p^.resulttype^.deftype=stringdef) and
  407. (pstringdef(def)^.string_typ=pstringdef(p^.resulttype)^.string_typ)
  408. )
  409. or
  410. (
  411. (p^.left^.treetype=stringconstn) and
  412. (is_ansistring(p^.resulttype) and is_pchar(def))
  413. )
  414. or
  415. (
  416. (p^.left^.treetype=ordconstn) and
  417. (is_char(p^.resulttype) and (is_shortstring(def) or is_ansistring(def)))
  418. )
  419. { set can also be a not yet converted array constructor }
  420. or
  421. (
  422. (def^.deftype=setdef) and (p^.resulttype^.deftype=arraydef) and
  423. (parraydef(p^.resulttype)^.IsConstructor) and not(parraydef(p^.resulttype)^.IsVariant)
  424. )
  425. { in tp7 mode proc -> procvar is allowed }
  426. or
  427. (
  428. (m_tp_procvar in aktmodeswitches) and
  429. (def^.deftype=procvardef) and (p^.left^.treetype=calln) and
  430. (proc_to_procvar_equal(pprocdef(p^.left^.procdefinition),pprocvardef(def)))
  431. )
  432. ;
  433. end;
  434. function is_in_limit(def_from,def_to : pdef) : boolean;
  435. begin
  436. is_in_limit:=(def_from^.deftype = orddef) and
  437. (def_to^.deftype = orddef) and
  438. (porddef(def_from)^.low>porddef(def_to)^.low) and
  439. (porddef(def_from)^.high<porddef(def_to)^.high);
  440. end;
  441. var
  442. is_const : boolean;
  443. begin
  444. { release registers! }
  445. { if procdefinition<>nil then we called firstpass already }
  446. { it seems to be bad because of the registers }
  447. { at least we can avoid the overloaded search !! }
  448. procs:=nil;
  449. { made this global for disposing !! }
  450. oldcallprocsym:=aktcallprocsym;
  451. aktcallprocsym:=nil;
  452. inlined:=false;
  453. if assigned(p^.procdefinition) and
  454. (pocall_inline in p^.procdefinition^.proccalloptions) then
  455. begin
  456. inlinecode:=p^.right;
  457. if assigned(inlinecode) then
  458. begin
  459. inlined:=true;
  460. exclude(p^.procdefinition^.proccalloptions,pocall_inline);
  461. end;
  462. p^.right:=nil;
  463. end;
  464. if assigned(p^.procdefinition) and
  465. (po_containsself in p^.procdefinition^.procoptions) then
  466. message(cg_e_cannot_call_message_direct);
  467. { procedure variable ? }
  468. if assigned(p^.right) then
  469. begin
  470. { procedure does a call }
  471. procinfo^.flags:=procinfo^.flags or pi_do_call;
  472. {$ifndef newcg}
  473. { calc the correture value for the register }
  474. {$ifdef i386}
  475. incrementregisterpushed($ff);
  476. {$endif}
  477. {$ifdef m68k}
  478. for regi:=R_D0 to R_A6 do
  479. inc(reg_pushes[regi],t_times*2);
  480. {$endif}
  481. {$endif newcg}
  482. { calculate the type of the parameters }
  483. if assigned(p^.left) then
  484. begin
  485. firstcallparan(p^.left,nil,false);
  486. if codegenerror then
  487. goto errorexit;
  488. end;
  489. firstpass(p^.right);
  490. set_varstate(p^.right,true);
  491. { check the parameters }
  492. pdc:=pparaitem(pprocvardef(p^.right^.resulttype)^.para^.first);
  493. pt:=p^.left;
  494. while assigned(pdc) and assigned(pt) do
  495. begin
  496. pt:=pt^.right;
  497. pdc:=pparaitem(pdc^.next);
  498. end;
  499. if assigned(pt) or assigned(pdc) then
  500. begin
  501. if assigned(pt) then
  502. aktfilepos:=pt^.fileinfo;
  503. CGMessage(parser_e_illegal_parameter_list);
  504. end;
  505. { insert type conversions }
  506. if assigned(p^.left) then
  507. begin
  508. firstcallparan(p^.left,pparaitem(pprocvardef(p^.right^.resulttype)^.para^.first),true);
  509. if codegenerror then
  510. goto errorexit;
  511. end;
  512. p^.resulttype:=pprocvardef(p^.right^.resulttype)^.rettype.def;
  513. { this was missing, leads to a bug below if
  514. the procvar is a function }
  515. p^.procdefinition:=pabstractprocdef(p^.right^.resulttype);
  516. end
  517. else
  518. { not a procedure variable }
  519. begin
  520. { determine the type of the parameters }
  521. if assigned(p^.left) then
  522. begin
  523. firstcallparan(p^.left,nil,false);
  524. if codegenerror then
  525. goto errorexit;
  526. end;
  527. aktcallprocsym:=pprocsym(p^.symtableprocentry);
  528. { do we know the procedure to call ? }
  529. if not(assigned(p^.procdefinition)) then
  530. begin
  531. {$ifdef TEST_PROCSYMS}
  532. if (p^.unit_specific) or
  533. assigned(p^.methodpointer) then
  534. nextprocsym:=nil
  535. else while not assigned(procs) do
  536. begin
  537. symt:=p^.symtableproc;
  538. srsym:=nil;
  539. while assigned(symt^.next) and not assigned(srsym) do
  540. begin
  541. symt:=symt^.next;
  542. getsymonlyin(symt,actprocsym^.name);
  543. if assigned(srsym) then
  544. if srsym^.typ<>procsym then
  545. begin
  546. { reject all that is not a procedure }
  547. srsym:=nil;
  548. { don't search elsewhere }
  549. while assigned(symt^.next) do
  550. symt:=symt^.next;
  551. end;
  552. end;
  553. nextprocsym:=srsym;
  554. end;
  555. {$endif TEST_PROCSYMS}
  556. { determine length of parameter list }
  557. pt:=p^.left;
  558. paralength:=0;
  559. while assigned(pt) do
  560. begin
  561. inc(paralength);
  562. pt:=pt^.right;
  563. end;
  564. { link all procedures which have the same # of parameters }
  565. pd:=aktcallprocsym^.definition;
  566. while assigned(pd) do
  567. begin
  568. { only when the # of parameter are equal }
  569. if (pd^.para^.count=paralength) then
  570. begin
  571. new(hp);
  572. hp^.data:=pd;
  573. hp^.next:=procs;
  574. hp^.nextpara:=pparaitem(pd^.para^.first);
  575. hp^.firstpara:=pparaitem(pd^.para^.first);
  576. procs:=hp;
  577. end;
  578. pd:=pd^.nextoverloaded;
  579. end;
  580. { no procedures found? then there is something wrong
  581. with the parameter size }
  582. if not assigned(procs) then
  583. begin
  584. { in tp mode we can try to convert to procvar if
  585. there are no parameters specified }
  586. if not(assigned(p^.left)) and
  587. (m_tp_procvar in aktmodeswitches) then
  588. begin
  589. if (p^.symtableprocentry^.owner^.symtabletype=objectsymtable) and
  590. (pobjectdef(p^.symtableprocentry^.owner^.defowner)^.is_class) then
  591. hpt:=genloadmethodcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc,
  592. getcopy(p^.methodpointer))
  593. else
  594. hpt:=genloadcallnode(pprocsym(p^.symtableprocentry),p^.symtableproc);
  595. disposetree(p);
  596. firstpass(hpt);
  597. p:=hpt;
  598. end
  599. else
  600. begin
  601. if assigned(p^.left) then
  602. aktfilepos:=p^.left^.fileinfo;
  603. CGMessage(parser_e_wrong_parameter_size);
  604. aktcallprocsym^.write_parameter_lists;
  605. end;
  606. goto errorexit;
  607. end;
  608. { now we can compare parameter after parameter }
  609. pt:=p^.left;
  610. { we start with the last parameter }
  611. lastpara:=paralength+1;
  612. lastparatype:=nil;
  613. while assigned(pt) do
  614. begin
  615. dec(lastpara);
  616. { walk all procedures and determine how this parameter matches and set:
  617. 1. pt^.exact_match_found if one parameter has an exact match
  618. 2. exactmatch if an equal or exact match is found
  619. 3. para^.argconvtyp to exact,equal or convertable
  620. (when convertable then also convertlevel is set)
  621. 4. pt^.convlevel1found if there is a convertlevel=1
  622. 5. pt^.convlevel2found if there is a convertlevel=2
  623. }
  624. exactmatch:=false;
  625. hp:=procs;
  626. while assigned(hp) do
  627. begin
  628. if is_equal(pt,hp^.nextpara^.paratype.def) then
  629. begin
  630. if hp^.nextpara^.paratype.def=pt^.resulttype then
  631. begin
  632. pt^.exact_match_found:=true;
  633. hp^.nextpara^.argconvtyp:=act_exact;
  634. end
  635. else
  636. hp^.nextpara^.argconvtyp:=act_equal;
  637. exactmatch:=true;
  638. end
  639. else
  640. begin
  641. hp^.nextpara^.argconvtyp:=act_convertable;
  642. hp^.nextpara^.convertlevel:=isconvertable(pt^.resulttype,hp^.nextpara^.paratype.def,
  643. hcvt,pt^.left^.treetype,false);
  644. case hp^.nextpara^.convertlevel of
  645. 1 : pt^.convlevel1found:=true;
  646. 2 : pt^.convlevel2found:=true;
  647. end;
  648. end;
  649. hp:=hp^.next;
  650. end;
  651. { If there was an exactmatch then delete all convertables }
  652. if exactmatch then
  653. begin
  654. hp:=procs;
  655. procs:=nil;
  656. while assigned(hp) do
  657. begin
  658. hp2:=hp^.next;
  659. { keep if not convertable }
  660. if (hp^.nextpara^.argconvtyp<>act_convertable) then
  661. begin
  662. hp^.next:=procs;
  663. procs:=hp;
  664. end
  665. else
  666. dispose(hp);
  667. hp:=hp2;
  668. end;
  669. end
  670. else
  671. { No exact match was found, remove all procedures that are
  672. not convertable (convertlevel=0) }
  673. begin
  674. hp:=procs;
  675. procs:=nil;
  676. while assigned(hp) do
  677. begin
  678. hp2:=hp^.next;
  679. { keep if not convertable }
  680. if (hp^.nextpara^.convertlevel<>0) then
  681. begin
  682. hp^.next:=procs;
  683. procs:=hp;
  684. end
  685. else
  686. begin
  687. { save the type for nice error message }
  688. lastparatype:=hp^.nextpara^.paratype.def;
  689. dispose(hp);
  690. end;
  691. hp:=hp2;
  692. end;
  693. end;
  694. { update nextpara for all procedures }
  695. hp:=procs;
  696. while assigned(hp) do
  697. begin
  698. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  699. hp:=hp^.next;
  700. end;
  701. { load next parameter or quit loop if no procs left }
  702. if assigned(procs) then
  703. pt:=pt^.right
  704. else
  705. break;
  706. end;
  707. { All parameters are checked, check if there are any
  708. procedures left }
  709. if not assigned(procs) then
  710. begin
  711. { there is an error, must be wrong type, because
  712. wrong size is already checked (PFV) }
  713. if (not assigned(lastparatype)) or
  714. (not assigned(pt)) or
  715. (not assigned(pt^.resulttype)) then
  716. internalerror(39393)
  717. else
  718. begin
  719. aktfilepos:=pt^.fileinfo;
  720. CGMessage3(type_e_wrong_parameter_type,tostr(lastpara),
  721. pt^.resulttype^.typename,lastparatype^.typename);
  722. end;
  723. aktcallprocsym^.write_parameter_lists;
  724. goto errorexit;
  725. end;
  726. { if there are several choices left then for orddef }
  727. { if a type is totally included in the other }
  728. { we don't fear an overflow , }
  729. { so we can do as if it is an exact match }
  730. { this will convert integer to longint }
  731. { rather than to words }
  732. { conversion of byte to integer or longint }
  733. {would still not be solved }
  734. if assigned(procs) and assigned(procs^.next) then
  735. begin
  736. hp:=procs;
  737. while assigned(hp) do
  738. begin
  739. hp^.nextpara:=hp^.firstpara;
  740. hp:=hp^.next;
  741. end;
  742. pt:=p^.left;
  743. while assigned(pt) do
  744. begin
  745. { matches a parameter of one procedure exact ? }
  746. exactmatch:=false;
  747. def_from:=pt^.resulttype;
  748. hp:=procs;
  749. while assigned(hp) do
  750. begin
  751. if not is_equal(pt,hp^.nextpara^.paratype.def) then
  752. begin
  753. def_to:=hp^.nextpara^.paratype.def;
  754. if ((def_from^.deftype=orddef) and (def_to^.deftype=orddef)) and
  755. (is_in_limit(def_from,def_to) or
  756. ((hp^.nextpara^.paratyp in [vs_var,vs_out]) and
  757. (def_from^.size=def_to^.size))) then
  758. begin
  759. exactmatch:=true;
  760. conv_to:=def_to;
  761. end;
  762. end;
  763. hp:=hp^.next;
  764. end;
  765. { .... if yes, del all the other procedures }
  766. if exactmatch then
  767. begin
  768. { the first .... }
  769. while (assigned(procs)) and not(is_in_limit(def_from,procs^.nextpara^.paratype.def)) do
  770. begin
  771. hp:=procs^.next;
  772. dispose(procs);
  773. procs:=hp;
  774. end;
  775. { and the others }
  776. hp:=procs;
  777. while (assigned(hp)) and assigned(hp^.next) do
  778. begin
  779. if not(is_in_limit(def_from,hp^.next^.nextpara^.paratype.def)) then
  780. begin
  781. hp2:=hp^.next^.next;
  782. dispose(hp^.next);
  783. hp^.next:=hp2;
  784. end
  785. else
  786. begin
  787. def_to:=hp^.next^.nextpara^.paratype.def;
  788. if (conv_to^.size>def_to^.size) or
  789. ((porddef(conv_to)^.low<porddef(def_to)^.low) and
  790. (porddef(conv_to)^.high>porddef(def_to)^.high)) then
  791. begin
  792. hp2:=procs;
  793. procs:=hp;
  794. conv_to:=def_to;
  795. dispose(hp2);
  796. end
  797. else
  798. hp:=hp^.next;
  799. end;
  800. end;
  801. end;
  802. { update nextpara for all procedures }
  803. hp:=procs;
  804. while assigned(hp) do
  805. begin
  806. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  807. hp:=hp^.next;
  808. end;
  809. pt:=pt^.right;
  810. end;
  811. end;
  812. { let's try to eliminate equal if there is an exact match
  813. is there }
  814. if assigned(procs) and assigned(procs^.next) then
  815. begin
  816. { reset nextpara for all procs left }
  817. hp:=procs;
  818. while assigned(hp) do
  819. begin
  820. hp^.nextpara:=hp^.firstpara;
  821. hp:=hp^.next;
  822. end;
  823. pt:=p^.left;
  824. while assigned(pt) do
  825. begin
  826. if pt^.exact_match_found then
  827. begin
  828. hp:=procs;
  829. procs:=nil;
  830. while assigned(hp) do
  831. begin
  832. hp2:=hp^.next;
  833. { keep the exact matches, dispose the others }
  834. if (hp^.nextpara^.argconvtyp=act_exact) then
  835. begin
  836. hp^.next:=procs;
  837. procs:=hp;
  838. end
  839. else
  840. dispose(hp);
  841. hp:=hp2;
  842. end;
  843. end;
  844. { update nextpara for all procedures }
  845. hp:=procs;
  846. while assigned(hp) do
  847. begin
  848. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  849. hp:=hp^.next;
  850. end;
  851. pt:=pt^.right;
  852. end;
  853. end;
  854. { Check if there are convertlevel 1 and 2 differences
  855. left for the parameters, then discard all convertlevel
  856. 2 procedures. The value of convlevelXfound can still
  857. be used, because all convertables are still here or
  858. not }
  859. if assigned(procs) and assigned(procs^.next) then
  860. begin
  861. { reset nextpara for all procs left }
  862. hp:=procs;
  863. while assigned(hp) do
  864. begin
  865. hp^.nextpara:=hp^.firstpara;
  866. hp:=hp^.next;
  867. end;
  868. pt:=p^.left;
  869. while assigned(pt) do
  870. begin
  871. if pt^.convlevel1found and pt^.convlevel2found then
  872. begin
  873. hp:=procs;
  874. procs:=nil;
  875. while assigned(hp) do
  876. begin
  877. hp2:=hp^.next;
  878. { keep all not act_convertable and all convertlevels=1 }
  879. if (hp^.nextpara^.argconvtyp<>act_convertable) or
  880. (hp^.nextpara^.convertlevel=1) then
  881. begin
  882. hp^.next:=procs;
  883. procs:=hp;
  884. end
  885. else
  886. dispose(hp);
  887. hp:=hp2;
  888. end;
  889. end;
  890. { update nextpara for all procedures }
  891. hp:=procs;
  892. while assigned(hp) do
  893. begin
  894. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  895. hp:=hp^.next;
  896. end;
  897. pt:=pt^.right;
  898. end;
  899. end;
  900. if not(assigned(procs)) or assigned(procs^.next) then
  901. begin
  902. CGMessage(cg_e_cant_choose_overload_function);
  903. aktcallprocsym^.write_parameter_lists;
  904. goto errorexit;
  905. end;
  906. {$ifdef TEST_PROCSYMS}
  907. if (procs=nil) and assigned(nextprocsym) then
  908. begin
  909. p^.symtableprocentry:=nextprocsym;
  910. p^.symtableproc:=symt;
  911. end;
  912. end ; { of while assigned(p^.symtableprocentry) do }
  913. {$endif TEST_PROCSYMS}
  914. if make_ref then
  915. begin
  916. procs^.data^.lastref:=new(pref,init(procs^.data^.lastref,@p^.fileinfo));
  917. inc(procs^.data^.refcount);
  918. if procs^.data^.defref=nil then
  919. procs^.data^.defref:=procs^.data^.lastref;
  920. end;
  921. p^.procdefinition:=procs^.data;
  922. p^.resulttype:=procs^.data^.rettype.def;
  923. { big error for with statements
  924. p^.symtableproc:=p^.procdefinition^.owner;
  925. but neede for overloaded operators !! }
  926. if p^.symtableproc=nil then
  927. p^.symtableproc:=p^.procdefinition^.owner;
  928. p^.location.loc:=LOC_MEM;
  929. {$ifdef CHAINPROCSYMS}
  930. { object with method read;
  931. call to read(x) will be a usual procedure call }
  932. if assigned(p^.methodpointer) and
  933. (p^.procdefinition^._class=nil) then
  934. begin
  935. { not ok for extended }
  936. case p^.methodpointer^.treetype of
  937. typen,hnewn : fatalerror(no_para_match);
  938. end;
  939. disposetree(p^.methodpointer);
  940. p^.methodpointer:=nil;
  941. end;
  942. {$endif CHAINPROCSYMS}
  943. end; { end of procedure to call determination }
  944. is_const:=(pocall_internconst in p^.procdefinition^.proccalloptions) and
  945. ((block_type=bt_const) or
  946. (assigned(p^.left) and (p^.left^.left^.treetype in [realconstn,ordconstn])));
  947. { handle predefined procedures }
  948. if (pocall_internproc in p^.procdefinition^.proccalloptions) or is_const then
  949. begin
  950. if assigned(p^.left) then
  951. begin
  952. { settextbuf needs two args }
  953. if assigned(p^.left^.right) then
  954. pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,is_const,p^.left)
  955. else
  956. begin
  957. pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,is_const,p^.left^.left);
  958. putnode(p^.left);
  959. end;
  960. end
  961. else
  962. begin
  963. pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,is_const,nil);
  964. end;
  965. putnode(p);
  966. firstpass(pt);
  967. p:=pt;
  968. goto errorexit;
  969. end
  970. else
  971. { no intern procedure => we do a call }
  972. { calc the correture value for the register }
  973. { handle predefined procedures }
  974. if (pocall_inline in p^.procdefinition^.proccalloptions) then
  975. begin
  976. if assigned(p^.methodpointer) then
  977. CGMessage(cg_e_unable_inline_object_methods);
  978. if assigned(p^.right) and (p^.right^.treetype<>procinlinen) then
  979. CGMessage(cg_e_unable_inline_procvar);
  980. { p^.treetype:=procinlinen; }
  981. if not assigned(p^.right) then
  982. begin
  983. if assigned(pprocdef(p^.procdefinition)^.code) then
  984. inlinecode:=genprocinlinenode(p,ptree(pprocdef(p^.procdefinition)^.code))
  985. else
  986. CGMessage(cg_e_no_code_for_inline_stored);
  987. if assigned(inlinecode) then
  988. begin
  989. { consider it has not inlined if called
  990. again inside the args }
  991. exclude(p^.procdefinition^.proccalloptions,pocall_inline);
  992. firstpass(inlinecode);
  993. inlined:=true;
  994. end;
  995. end;
  996. end
  997. else
  998. procinfo^.flags:=procinfo^.flags or pi_do_call;
  999. {if (po_interrupt in p^.procdefinition^.procoptions) then
  1000. CGmessage1(cg_e_no_call_to_interrupt,p^.symtableprocentry^.name);}
  1001. { work trough all parameters to insert the type conversions }
  1002. { !!! done now after internproc !! (PM) }
  1003. if assigned(p^.left) then
  1004. begin
  1005. firstcallparan(p^.left,pparaitem(p^.procdefinition^.para^.first),true);
  1006. end;
  1007. {$ifndef newcg}
  1008. {$ifdef i386}
  1009. incrementregisterpushed(pprocdef(p^.procdefinition)^.usedregisters);
  1010. {$endif}
  1011. {$ifdef m68k}
  1012. for regi:=R_D0 to R_A6 do
  1013. begin
  1014. if (pprocdef(p^.procdefinition)^.usedregisters and ($800 shr word(regi)))<>0 then
  1015. inc(reg_pushes[regi],t_times*2);
  1016. end;
  1017. {$endif}
  1018. {$endif newcg}
  1019. end;
  1020. { ensure that the result type is set }
  1021. p^.resulttype:=p^.procdefinition^.rettype.def;
  1022. { get a register for the return value }
  1023. if (p^.resulttype<>pdef(voiddef)) then
  1024. begin
  1025. if (p^.procdefinition^.proctypeoption=potype_constructor) then
  1026. begin
  1027. { extra handling of classes }
  1028. { p^.methodpointer should be assigned! }
  1029. if assigned(p^.methodpointer) and assigned(p^.methodpointer^.resulttype) and
  1030. (p^.methodpointer^.resulttype^.deftype=classrefdef) then
  1031. begin
  1032. p^.location.loc:=LOC_REGISTER;
  1033. p^.registers32:=1;
  1034. { the result type depends on the classref }
  1035. p^.resulttype:=pclassrefdef(p^.methodpointer^.resulttype)^.pointertype.def;
  1036. end
  1037. { a object constructor returns the result with the flags }
  1038. else
  1039. p^.location.loc:=LOC_FLAGS;
  1040. end
  1041. else
  1042. begin
  1043. {$ifdef SUPPORT_MMX}
  1044. if (cs_mmx in aktlocalswitches) and
  1045. is_mmx_able_array(p^.resulttype) then
  1046. begin
  1047. p^.location.loc:=LOC_MMXREGISTER;
  1048. p^.registersmmx:=1;
  1049. end
  1050. else
  1051. {$endif SUPPORT_MMX}
  1052. if ret_in_acc(p^.resulttype) then
  1053. begin
  1054. p^.location.loc:=LOC_REGISTER;
  1055. if is_64bitint(p^.resulttype) then
  1056. p^.registers32:=2
  1057. else
  1058. p^.registers32:=1;
  1059. { wide- and ansistrings are returned in EAX }
  1060. { but they are imm. moved to a memory location }
  1061. if is_widestring(p^.resulttype) or
  1062. is_ansistring(p^.resulttype) then
  1063. begin
  1064. p^.location.loc:=LOC_MEM;
  1065. { this is wrong we still need one register PM
  1066. p^.registers32:=0; }
  1067. { we use ansistrings so no fast exit here }
  1068. procinfo^.no_fast_exit:=true;
  1069. p^.registers32:=1;
  1070. end;
  1071. end
  1072. else if (p^.resulttype^.deftype=floatdef) then
  1073. begin
  1074. p^.location.loc:=LOC_FPU;
  1075. p^.registersfpu:=1;
  1076. end
  1077. else
  1078. p^.location.loc:=LOC_MEM;
  1079. end;
  1080. end;
  1081. { a fpu can be used in any procedure !! }
  1082. p^.registersfpu:=p^.procdefinition^.fpu_used;
  1083. { if this is a call to a method calc the registers }
  1084. if (p^.methodpointer<>nil) then
  1085. begin
  1086. case p^.methodpointer^.treetype of
  1087. { but only, if this is not a supporting node }
  1088. typen: ;
  1089. { we need one register for new return value PM }
  1090. hnewn : if p^.registers32=0 then
  1091. p^.registers32:=1;
  1092. else
  1093. begin
  1094. if (p^.procdefinition^.proctypeoption in [potype_constructor,potype_destructor]) and
  1095. assigned(p^.symtable) and (p^.symtable^.symtabletype=withsymtable) and
  1096. not pwithsymtable(p^.symtable)^.direct_with then
  1097. begin
  1098. CGmessage(cg_e_cannot_call_cons_dest_inside_with);
  1099. end; { Is accepted by Delphi !! }
  1100. { this is not a good reason to accept it in FPC if we produce
  1101. wrong code for it !!! (PM) }
  1102. { R.Assign is not a constructor !!! }
  1103. { but for R^.Assign, R must be valid !! }
  1104. if (p^.procdefinition^.proctypeoption=potype_constructor) or
  1105. ((p^.methodpointer^.treetype=loadn) and
  1106. (not(oo_has_virtual in pobjectdef(p^.methodpointer^.resulttype)^.objectoptions))) then
  1107. method_must_be_valid:=false
  1108. else
  1109. method_must_be_valid:=true;
  1110. firstpass(p^.methodpointer);
  1111. set_varstate(p^.methodpointer,method_must_be_valid);
  1112. { The object is already used ven if it is called once }
  1113. if (p^.methodpointer^.treetype=loadn) and
  1114. (p^.methodpointer^.symtableentry^.typ=varsym) then
  1115. pvarsym(p^.methodpointer^.symtableentry)^.varstate:=vs_used;
  1116. p^.registersfpu:=max(p^.methodpointer^.registersfpu,p^.registersfpu);
  1117. p^.registers32:=max(p^.methodpointer^.registers32,p^.registers32);
  1118. {$ifdef SUPPORT_MMX}
  1119. p^.registersmmx:=max(p^.methodpointer^.registersmmx,p^.registersmmx);
  1120. {$endif SUPPORT_MMX}
  1121. end;
  1122. end;
  1123. end;
  1124. if inlined then
  1125. p^.right:=inlinecode;
  1126. { determine the registers of the procedure variable }
  1127. { is this OK for inlined procs also ?? (PM) }
  1128. if assigned(p^.right) then
  1129. begin
  1130. p^.registersfpu:=max(p^.right^.registersfpu,p^.registersfpu);
  1131. p^.registers32:=max(p^.right^.registers32,p^.registers32);
  1132. {$ifdef SUPPORT_MMX}
  1133. p^.registersmmx:=max(p^.right^.registersmmx,p^.registersmmx);
  1134. {$endif SUPPORT_MMX}
  1135. end;
  1136. { determine the registers of the procedure }
  1137. if assigned(p^.left) then
  1138. begin
  1139. p^.registersfpu:=max(p^.left^.registersfpu,p^.registersfpu);
  1140. p^.registers32:=max(p^.left^.registers32,p^.registers32);
  1141. {$ifdef SUPPORT_MMX}
  1142. p^.registersmmx:=max(p^.left^.registersmmx,p^.registersmmx);
  1143. {$endif SUPPORT_MMX}
  1144. end;
  1145. errorexit:
  1146. { Reset some settings back }
  1147. if assigned(procs) then
  1148. dispose(procs);
  1149. if inlined then
  1150. include(p^.procdefinition^.proccalloptions,pocall_inline);
  1151. aktcallprocsym:=oldcallprocsym;
  1152. end;
  1153. {*****************************************************************************
  1154. FirstProcInlineN
  1155. *****************************************************************************}
  1156. procedure firstprocinline(var p : ptree);
  1157. begin
  1158. { left contains the code in tree form }
  1159. { but it has already been firstpassed }
  1160. { so firstpass(p^.left); does not seem required }
  1161. { might be required later if we change the arg handling !! }
  1162. end;
  1163. end.
  1164. {
  1165. $Log$
  1166. Revision 1.3 2000-07-13 12:08:28 michael
  1167. + patched to 1.1.0 with former 1.09patch from peter
  1168. Revision 1.2 2000/07/13 11:32:51 michael
  1169. + removed logs
  1170. }