ncal.pas 67 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 by Florian Klaempfl
  4. This file implements the node for sub procedure calling
  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. unit ncal;
  19. {$i defines.inc}
  20. interface
  21. uses
  22. node,
  23. symbase,symsym,symdef,symtable;
  24. type
  25. tcallnode = class(tbinarynode)
  26. { the symbol containing the definition of the procedure }
  27. { to call }
  28. symtableprocentry : tprocsym;
  29. { the symtable containing symtableprocentry }
  30. symtableproc : tsymtable;
  31. { the definition of the procedure to call }
  32. procdefinition : tabstractprocdef;
  33. methodpointer : tnode;
  34. { only the processor specific nodes need to override this }
  35. { constructor }
  36. constructor create(l:tnode; v : tprocsym;st : tsymtable; mp : tnode);virtual;
  37. destructor destroy;override;
  38. function getcopy : tnode;override;
  39. procedure insertintolist(l : tnodelist);override;
  40. function pass_1 : tnode;override;
  41. function det_resulttype:tnode;override;
  42. function docompare(p: tnode): boolean; override;
  43. procedure set_procvar(procvar:tnode);
  44. end;
  45. tcallparaflags = (
  46. { flags used by tcallparanode }
  47. cpf_exact_match_found,
  48. cpf_convlevel1found,
  49. cpf_convlevel2found,
  50. cpf_is_colon_para
  51. );
  52. tcallparanode = class(tbinarynode)
  53. callparaflags : set of tcallparaflags;
  54. hightree : tnode;
  55. { only the processor specific nodes need to override this }
  56. { constructor }
  57. constructor create(expr,next : tnode);virtual;
  58. destructor destroy;override;
  59. function getcopy : tnode;override;
  60. procedure insertintolist(l : tnodelist);override;
  61. procedure gen_high_tree(openstring:boolean);
  62. procedure get_paratype;
  63. procedure insert_typeconv(defcoll : tparaitem;do_count : boolean);
  64. procedure det_registers;
  65. procedure firstcallparan(defcoll : tparaitem;do_count : boolean);
  66. procedure secondcallparan(defcoll : tparaitem;
  67. push_from_left_to_right,inlined,is_cdecl : boolean;
  68. para_alignment,para_offset : longint);virtual;abstract;
  69. function docompare(p: tnode): boolean; override;
  70. end;
  71. tprocinlinenode = class(tnode)
  72. inlinetree : tnode;
  73. inlineprocsym : tprocsym;
  74. retoffset,para_offset,para_size : longint;
  75. constructor create(callp,code : tnode);virtual;
  76. destructor destroy;override;
  77. function getcopy : tnode;override;
  78. procedure insertintolist(l : tnodelist);override;
  79. function pass_1 : tnode;override;
  80. function docompare(p: tnode): boolean; override;
  81. end;
  82. var
  83. ccallnode : class of tcallnode;
  84. ccallparanode : class of tcallparanode;
  85. cprocinlinenode : class of tprocinlinenode;
  86. implementation
  87. uses
  88. cutils,globtype,systems,
  89. verbose,globals,
  90. symconst,symtype,types,
  91. htypechk,pass_1,cpubase,
  92. ncnv,nld,ninl,nadd,ncon,hcodegen,
  93. tgcpu
  94. {$ifdef newcg}
  95. ,cgbase
  96. {$endif newcg}
  97. ;
  98. {****************************************************************************
  99. TCALLPARANODE
  100. ****************************************************************************}
  101. constructor tcallparanode.create(expr,next : tnode);
  102. begin
  103. inherited create(callparan,expr,next);
  104. hightree:=nil;
  105. if assigned(expr) then
  106. expr.set_file_line(self);
  107. callparaflags:=[];
  108. end;
  109. destructor tcallparanode.destroy;
  110. begin
  111. hightree.free;
  112. inherited destroy;
  113. end;
  114. function tcallparanode.getcopy : tnode;
  115. var
  116. n : tcallparanode;
  117. begin
  118. n:=tcallparanode(inherited getcopy);
  119. n.callparaflags:=callparaflags;
  120. if assigned(hightree) then
  121. n.hightree:=hightree.getcopy
  122. else
  123. n.hightree:=nil;
  124. result:=n;
  125. end;
  126. procedure tcallparanode.insertintolist(l : tnodelist);
  127. begin
  128. end;
  129. procedure tcallparanode.get_paratype;
  130. var
  131. old_get_para_resulttype : boolean;
  132. old_array_constructor : boolean;
  133. begin
  134. inc(parsing_para_level);
  135. if assigned(right) then
  136. tcallparanode(right).get_paratype;
  137. old_array_constructor:=allow_array_constructor;
  138. old_get_para_resulttype:=get_para_resulttype;
  139. get_para_resulttype:=true;
  140. allow_array_constructor:=true;
  141. resulttypepass(left);
  142. get_para_resulttype:=old_get_para_resulttype;
  143. allow_array_constructor:=old_array_constructor;
  144. if codegenerror then
  145. resulttype:=generrortype
  146. else
  147. resulttype:=left.resulttype;
  148. dec(parsing_para_level);
  149. end;
  150. procedure tcallparanode.insert_typeconv(defcoll : tparaitem;do_count : boolean);
  151. var
  152. oldtype : ttype;
  153. {$ifdef extdebug}
  154. store_count_ref : boolean;
  155. {$endif def extdebug}
  156. begin
  157. inc(parsing_para_level);
  158. {$ifdef extdebug}
  159. if do_count then
  160. begin
  161. store_count_ref:=count_ref;
  162. count_ref:=true;
  163. end;
  164. {$endif def extdebug}
  165. if assigned(right) then
  166. begin
  167. if defcoll=nil then
  168. tcallparanode(right).insert_typeconv(nil,do_count)
  169. else
  170. tcallparanode(right).insert_typeconv(tparaitem(defcoll.next),do_count);
  171. end;
  172. { Be sure to have the resulttype }
  173. if not assigned(left.resulttype.def) then
  174. resulttypepass(left);
  175. { Do we need arrayconstructor -> set conversion, then insert
  176. it here before the arrayconstructor node breaks the tree
  177. with its conversions of enum->ord }
  178. if (left.nodetype=arrayconstructorn) and
  179. (defcoll.paratype.def.deftype=setdef) then
  180. inserttypeconv(left,defcoll.paratype);
  181. { set some settings needed for arrayconstructor }
  182. if is_array_constructor(left.resulttype.def) then
  183. begin
  184. if is_array_of_const(defcoll.paratype.def) then
  185. begin
  186. if assigned(aktcallprocsym) and
  187. (([pocall_cppdecl,pocall_cdecl]*aktcallprocsym.definition.proccalloptions)<>[]) and
  188. (po_external in aktcallprocsym.definition.procoptions) then
  189. include(left.flags,nf_cargs);
  190. { force variant array }
  191. include(left.flags,nf_forcevaria);
  192. end
  193. else
  194. begin
  195. include(left.flags,nf_novariaallowed);
  196. tarrayconstructornode(left).constructortype:=tarraydef(defcoll.paratype.def).elementtype;
  197. end;
  198. end;
  199. if do_count then
  200. begin
  201. { not completly proper, but avoids some warnings }
  202. if (defcoll.paratyp in [vs_var,vs_out]) then
  203. set_funcret_is_valid(left);
  204. { protected has nothing to do with read/write
  205. if (defcoll.paratyp in [vs_var,vs_out]) then
  206. test_protected(left);
  207. }
  208. { set_varstate(left,defcoll.paratyp<>vs_var);
  209. must only be done after typeconv PM }
  210. { only process typeconvn and arrayconstructn, else it will
  211. break other trees }
  212. { But this is need to get correct varstate !! PM }
  213. {old_array_constructor:=allow_array_constructor;
  214. old_get_para_resulttype:=get_para_resulttype;
  215. allow_array_constructor:=true;
  216. get_para_resulttype:=false;
  217. if (left.nodetype in [arrayconstructorn,typeconvn]) then
  218. firstpass(left);
  219. if not assigned(resulttype.def) then
  220. resulttype:=left.resulttype;
  221. get_para_resulttype:=old_get_para_resulttype;
  222. allow_array_constructor:=old_array_constructor; }
  223. end;
  224. { check if local proc/func is assigned to procvar }
  225. if left.resulttype.def.deftype=procvardef then
  226. test_local_to_procvar(tprocvardef(left.resulttype.def),defcoll.paratype.def);
  227. { property is not allowed as var parameter }
  228. if (defcoll.paratyp in [vs_out,vs_var]) and
  229. (nf_isproperty in left.flags) then
  230. CGMessagePos(left.fileinfo,type_e_argument_cant_be_assigned);
  231. { generate the high() value tree }
  232. if not(assigned(aktcallprocsym) and
  233. (([pocall_cppdecl,pocall_cdecl]*aktcallprocsym.definition.proccalloptions)<>[]) and
  234. (po_external in aktcallprocsym.definition.procoptions)) and
  235. push_high_param(defcoll.paratype.def) then
  236. gen_high_tree(is_open_string(defcoll.paratype.def));
  237. if not(is_shortstring(left.resulttype.def) and
  238. is_shortstring(defcoll.paratype.def)) and
  239. (defcoll.paratype.def.deftype<>formaldef) then
  240. begin
  241. if (defcoll.paratyp in [vs_var,vs_out]) and
  242. { allows conversion from word to integer and
  243. byte to shortint, but only for TP7 compatibility }
  244. (not(
  245. (m_tp7 in aktmodeswitches) and
  246. (left.resulttype.def.deftype=orddef) and
  247. (defcoll.paratype.def.deftype=orddef) and
  248. (left.resulttype.def.size=defcoll.paratype.def.size)
  249. ) and
  250. { an implicit pointer conversion is allowed }
  251. not(
  252. (left.resulttype.def.deftype=pointerdef) and
  253. (defcoll.paratype.def.deftype=pointerdef)
  254. ) and
  255. { child classes can be also passed }
  256. not(
  257. (left.resulttype.def.deftype=objectdef) and
  258. (defcoll.paratype.def.deftype=objectdef) and
  259. tobjectdef(left.resulttype.def).is_related(tobjectdef(defcoll.paratype.def))
  260. ) and
  261. { passing a single element to a openarray of the same type }
  262. not(
  263. (is_open_array(defcoll.paratype.def) and
  264. is_equal(tarraydef(defcoll.paratype.def).elementtype.def,left.resulttype.def))
  265. ) and
  266. { an implicit file conversion is also allowed }
  267. { from a typed file to an untyped one }
  268. not(
  269. (left.resulttype.def.deftype=filedef) and
  270. (defcoll.paratype.def.deftype=filedef) and
  271. (tfiledef(defcoll.paratype.def).filetyp = ft_untyped) and
  272. (tfiledef(left.resulttype.def).filetyp = ft_typed)
  273. ) and
  274. not(is_equal(left.resulttype.def,defcoll.paratype.def))) then
  275. begin
  276. CGMessagePos2(left.fileinfo,parser_e_call_by_ref_without_typeconv,
  277. left.resulttype.def.typename,defcoll.paratype.def.typename);
  278. end;
  279. { Process open parameters }
  280. if push_high_param(defcoll.paratype.def) then
  281. begin
  282. { insert type conv but hold the ranges of the array }
  283. oldtype:=left.resulttype;
  284. inserttypeconv(left,defcoll.paratype);
  285. left.resulttype:=oldtype;
  286. end
  287. else
  288. begin
  289. inserttypeconv(left,defcoll.paratype);
  290. end;
  291. if codegenerror then
  292. begin
  293. dec(parsing_para_level);
  294. exit;
  295. end;
  296. end;
  297. { check var strings }
  298. if (cs_strict_var_strings in aktlocalswitches) and
  299. is_shortstring(left.resulttype.def) and
  300. is_shortstring(defcoll.paratype.def) and
  301. (defcoll.paratyp in [vs_out,vs_var]) and
  302. not(is_open_string(defcoll.paratype.def)) and
  303. not(is_equal(left.resulttype.def,defcoll.paratype.def)) then
  304. begin
  305. aktfilepos:=left.fileinfo;
  306. CGMessage(type_e_strict_var_string_violation);
  307. end;
  308. { variabls for call by reference may not be copied }
  309. { into a register }
  310. { is this usefull here ? }
  311. { this was missing in formal parameter list }
  312. if (defcoll.paratype.def.deftype=formaldef) then
  313. begin
  314. if defcoll.paratyp in [vs_var,vs_out] then
  315. begin
  316. if not valid_for_formal_var(left) then
  317. begin
  318. aktfilepos:=left.fileinfo;
  319. CGMessage(parser_e_illegal_parameter_list);
  320. end;
  321. end;
  322. if defcoll.paratyp=vs_const then
  323. begin
  324. if not valid_for_formal_const(left) then
  325. begin
  326. aktfilepos:=left.fileinfo;
  327. CGMessage(parser_e_illegal_parameter_list);
  328. end;
  329. end;
  330. end;
  331. if defcoll.paratyp in [vs_var,vs_const] then
  332. begin
  333. { Causes problems with const ansistrings if also }
  334. { done for vs_const (JM) }
  335. if defcoll.paratyp = vs_var then
  336. set_unique(left);
  337. make_not_regable(left);
  338. end;
  339. { ansistrings out paramaters doesn't need to be }
  340. { unique, they are finalized }
  341. if defcoll.paratyp=vs_out then
  342. make_not_regable(left);
  343. if do_count then
  344. set_varstate(left,not(defcoll.paratyp in [vs_var,vs_out]));
  345. { must only be done after typeconv PM }
  346. resulttype:=defcoll.paratype;
  347. dec(parsing_para_level);
  348. {$ifdef extdebug}
  349. if do_count then
  350. count_ref:=store_count_ref;
  351. {$endif def extdebug}
  352. end;
  353. procedure tcallparanode.det_registers;
  354. var
  355. old_get_para_resulttype : boolean;
  356. old_array_constructor : boolean;
  357. begin
  358. if assigned(right) then
  359. begin
  360. tcallparanode(right).det_registers;
  361. registers32:=right.registers32;
  362. registersfpu:=right.registersfpu;
  363. {$ifdef SUPPORT_MMX}
  364. registersmmx:=right.registersmmx;
  365. {$endif}
  366. end;
  367. old_array_constructor:=allow_array_constructor;
  368. old_get_para_resulttype:=get_para_resulttype;
  369. get_para_resulttype:=true;
  370. allow_array_constructor:=true;
  371. firstpass(left);
  372. get_para_resulttype:=old_get_para_resulttype;
  373. allow_array_constructor:=old_array_constructor;
  374. if left.registers32>registers32 then
  375. registers32:=left.registers32;
  376. if left.registersfpu>registersfpu then
  377. registersfpu:=left.registersfpu;
  378. {$ifdef SUPPORT_MMX}
  379. if left.registersmmx>registersmmx then
  380. registersmmx:=left.registersmmx;
  381. {$endif SUPPORT_MMX}
  382. end;
  383. procedure tcallparanode.firstcallparan(defcoll : tparaitem;do_count : boolean);
  384. begin
  385. if not assigned(left.resulttype.def) then
  386. begin
  387. get_paratype;
  388. if assigned(defcoll) then
  389. insert_typeconv(defcoll,do_count);
  390. end;
  391. det_registers;
  392. end;
  393. procedure tcallparanode.gen_high_tree(openstring:boolean);
  394. var
  395. len : longint;
  396. st : tsymtable;
  397. loadconst : boolean;
  398. srsym : tsym;
  399. begin
  400. if assigned(hightree) then
  401. exit;
  402. len:=-1;
  403. loadconst:=true;
  404. case left.resulttype.def.deftype of
  405. arraydef :
  406. begin
  407. if is_open_array(left.resulttype.def) or
  408. is_array_of_const(left.resulttype.def) then
  409. begin
  410. st:=tloadnode(left).symtable;
  411. srsym:=searchsymonlyin(st,'high'+tvarsym(tloadnode(left).symtableentry).name);
  412. hightree:=cloadnode.create(tvarsym(srsym),st);
  413. loadconst:=false;
  414. end
  415. else
  416. begin
  417. { this is an empty constructor }
  418. len:=tarraydef(left.resulttype.def).highrange-
  419. tarraydef(left.resulttype.def).lowrange;
  420. end;
  421. end;
  422. stringdef :
  423. begin
  424. if openstring then
  425. begin
  426. if is_open_string(left.resulttype.def) then
  427. begin
  428. st:=tloadnode(left).symtable;
  429. srsym:=searchsymonlyin(st,'high'+tvarsym(tloadnode(left).symtableentry).name);
  430. hightree:=cloadnode.create(tvarsym(srsym),st);
  431. loadconst:=false;
  432. end
  433. else
  434. len:=tstringdef(left.resulttype.def).len;
  435. end
  436. else
  437. { passing a string to an array of char }
  438. begin
  439. if (left.nodetype=stringconstn) then
  440. begin
  441. len:=str_length(left);
  442. if len>0 then
  443. dec(len);
  444. end
  445. else
  446. begin
  447. hightree:=caddnode.create(subn,geninlinenode(in_length_string,false,left.getcopy),
  448. cordconstnode.create(1,s32bittype));
  449. firstpass(hightree);
  450. hightree:=ctypeconvnode.create(hightree,s32bittype);
  451. loadconst:=false;
  452. end;
  453. end;
  454. end;
  455. else
  456. len:=0;
  457. end;
  458. if loadconst then
  459. hightree:=cordconstnode.create(len,s32bittype);
  460. firstpass(hightree);
  461. end;
  462. function tcallparanode.docompare(p: tnode): boolean;
  463. begin
  464. docompare :=
  465. inherited docompare(p) and
  466. (callparaflags = tcallparanode(p).callparaflags) and
  467. hightree.isequal(tcallparanode(p).hightree);
  468. end;
  469. {****************************************************************************
  470. TCALLNODE
  471. ****************************************************************************}
  472. constructor tcallnode.create(l:tnode;v : tprocsym;st : tsymtable; mp : tnode);
  473. begin
  474. inherited create(calln,l,nil);
  475. symtableprocentry:=v;
  476. symtableproc:=st;
  477. include(flags,nf_return_value_used);
  478. methodpointer:=mp;
  479. procdefinition:=nil;
  480. end;
  481. destructor tcallnode.destroy;
  482. begin
  483. methodpointer.free;
  484. inherited destroy;
  485. end;
  486. procedure tcallnode.set_procvar(procvar:tnode);
  487. begin
  488. right:=procvar;
  489. end;
  490. function tcallnode.getcopy : tnode;
  491. var
  492. n : tcallnode;
  493. begin
  494. n:=tcallnode(inherited getcopy);
  495. n.symtableprocentry:=symtableprocentry;
  496. n.symtableproc:=symtableproc;
  497. n.procdefinition:=procdefinition;
  498. if assigned(methodpointer) then
  499. n.methodpointer:=methodpointer.getcopy
  500. else
  501. n.methodpointer:=nil;
  502. result:=n;
  503. end;
  504. procedure tcallnode.insertintolist(l : tnodelist);
  505. begin
  506. end;
  507. function tcallnode.det_resulttype:tnode;
  508. type
  509. pprocdefcoll = ^tprocdefcoll;
  510. tprocdefcoll = record
  511. data : tprocdef;
  512. nextpara : tparaitem;
  513. firstpara : tparaitem;
  514. next : pprocdefcoll;
  515. end;
  516. var
  517. hp,procs,hp2 : pprocdefcoll;
  518. pd : tprocdef;
  519. oldcallprocsym : tprocsym;
  520. def_from,def_to,conv_to : tdef;
  521. hpt : tnode;
  522. pt : tcallparanode;
  523. exactmatch : boolean;
  524. paralength,lastpara : longint;
  525. lastparatype : tdef;
  526. pdc : tparaitem;
  527. {$ifdef TEST_PROCSYMS}
  528. nextprocsym : tprocsym;
  529. symt : tsymtable;
  530. {$endif TEST_PROCSYMS}
  531. { only Dummy }
  532. hcvt : tconverttype;
  533. label
  534. errorexit;
  535. { check if the resulttype.def from tree p is equal with def, needed
  536. for stringconstn and formaldef }
  537. function is_equal(p:tcallparanode;def:tdef) : boolean;
  538. begin
  539. { safety check }
  540. if not (assigned(def) or assigned(p.resulttype.def)) then
  541. begin
  542. is_equal:=false;
  543. exit;
  544. end;
  545. { all types can be passed to a formaldef }
  546. is_equal:=(def.deftype=formaldef) or
  547. (types.is_equal(p.resulttype.def,def))
  548. { integer constants are compatible with all integer parameters if
  549. the specified value matches the range }
  550. or
  551. (
  552. (tbinarynode(p).left.nodetype=ordconstn) and
  553. is_integer(p.resulttype.def) and
  554. is_integer(def) and
  555. (tordconstnode(p.left).value>=torddef(def).low) and
  556. (tordconstnode(p.left).value<=torddef(def).high)
  557. )
  558. { to support ansi/long/wide strings in a proper way }
  559. { string and string[10] are assumed as equal }
  560. { when searching the correct overloaded procedure }
  561. or
  562. (
  563. (def.deftype=stringdef) and (p.resulttype.def.deftype=stringdef) and
  564. (tstringdef(def).string_typ=tstringdef(p.resulttype.def).string_typ)
  565. )
  566. or
  567. (
  568. (p.left.nodetype=stringconstn) and
  569. (is_ansistring(p.resulttype.def) and is_pchar(def))
  570. )
  571. or
  572. (
  573. (p.left.nodetype=ordconstn) and
  574. (is_char(p.resulttype.def) and (is_shortstring(def) or is_ansistring(def)))
  575. )
  576. { set can also be a not yet converted array constructor }
  577. or
  578. (
  579. (def.deftype=setdef) and (p.resulttype.def.deftype=arraydef) and
  580. (tarraydef(p.resulttype.def).IsConstructor) and not(tarraydef(p.resulttype.def).IsVariant)
  581. )
  582. { in tp7 mode proc -> procvar is allowed }
  583. or
  584. (
  585. (m_tp_procvar in aktmodeswitches) and
  586. (def.deftype=procvardef) and (p.left.nodetype=calln) and
  587. (proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def)))
  588. )
  589. ;
  590. end;
  591. function is_in_limit(def_from,def_to : tdef) : boolean;
  592. begin
  593. is_in_limit:=(def_from.deftype = orddef) and
  594. (def_to.deftype = orddef) and
  595. (torddef(def_from).low>torddef(def_to).low) and
  596. (torddef(def_from).high<torddef(def_to).high);
  597. end;
  598. var
  599. i : longint;
  600. is_const : boolean;
  601. bestord : torddef;
  602. begin
  603. result:=nil;
  604. procs:=nil;
  605. oldcallprocsym:=aktcallprocsym;
  606. aktcallprocsym:=nil;
  607. { procedure variable ? }
  608. if assigned(right) then
  609. begin
  610. set_varstate(right,true);
  611. resulttypepass(right);
  612. if codegenerror then
  613. exit;
  614. { check the parameters }
  615. pdc:=tparaitem(tprocvardef(right.resulttype.def).Para.first);
  616. pt:=tcallparanode(left);
  617. while assigned(pdc) and assigned(pt) do
  618. begin
  619. pt:=tcallparanode(pt.right);
  620. pdc:=tparaitem(pdc.next);
  621. end;
  622. if assigned(pt) or assigned(pdc) then
  623. begin
  624. if assigned(pt) then
  625. aktfilepos:=pt.fileinfo;
  626. CGMessage(parser_e_illegal_parameter_list);
  627. end;
  628. procdefinition:=tabstractprocdef(right.resulttype.def);
  629. end
  630. else
  631. { not a procedure variable }
  632. begin
  633. { determine the type of the parameters }
  634. if assigned(left) then
  635. begin
  636. tcallparanode(left).get_paratype;
  637. if codegenerror then
  638. goto errorexit;
  639. end;
  640. aktcallprocsym:=tprocsym(symtableprocentry);
  641. { do we know the procedure to call ? }
  642. if not(assigned(procdefinition)) then
  643. begin
  644. {$ifdef TEST_PROCSYMS}
  645. if (unit_specific) or
  646. assigned(methodpointer) then
  647. nextprocsym:=nil
  648. else while not assigned(procs) do
  649. begin
  650. symt:=symtableproc;
  651. srsym:=nil;
  652. while assigned(symt^.next) and not assigned(srsym) do
  653. begin
  654. symt:=symt^.next;
  655. srsym:=searchsymonlyin(symt,actprocsym.name);
  656. if assigned(srsym) then
  657. if srsym.typ<>procsym then
  658. begin
  659. { reject all that is not a procedure }
  660. srsym:=nil;
  661. { don't search elsewhere }
  662. while assigned(symt^.next) do
  663. symt:=symt^.next;
  664. end;
  665. end;
  666. nextprocsym:=srsym;
  667. end;
  668. {$endif TEST_PROCSYMS}
  669. { determine length of parameter list }
  670. pt:=tcallparanode(left);
  671. paralength:=0;
  672. while assigned(pt) do
  673. begin
  674. inc(paralength);
  675. pt:=tcallparanode(pt.right);
  676. end;
  677. { link all procedures which have the same # of parameters }
  678. pd:=aktcallprocsym.definition;
  679. while assigned(pd) do
  680. begin
  681. { only when the # of parameter are supported by the
  682. procedure }
  683. if (paralength>=pd.minparacount) and (paralength<=pd.maxparacount) then
  684. begin
  685. new(hp);
  686. hp^.data:=pd;
  687. hp^.next:=procs;
  688. hp^.firstpara:=tparaitem(pd.Para.first);
  689. { if not all parameters are given, then skip the
  690. default parameters }
  691. for i:=1 to pd.maxparacount-paralength do
  692. hp^.firstpara:=tparaitem(hp^.firstPara.next);
  693. hp^.nextpara:=hp^.firstpara;
  694. procs:=hp;
  695. end;
  696. pd:=pd.nextoverloaded;
  697. end;
  698. { no procedures found? then there is something wrong
  699. with the parameter size }
  700. if not assigned(procs) then
  701. begin
  702. { in tp mode we can try to convert to procvar if
  703. there are no parameters specified }
  704. if not(assigned(left)) and
  705. (m_tp_procvar in aktmodeswitches) then
  706. begin
  707. hpt:=cloadnode.create(tprocsym(symtableprocentry),symtableproc);
  708. if (symtableprocentry.owner.symtabletype=objectsymtable) and
  709. assigned(methodpointer) then
  710. tloadnode(hpt).set_mp(methodpointer.getcopy);
  711. resulttypepass(hpt);
  712. right:=hpt;
  713. end
  714. else
  715. begin
  716. if assigned(left) then
  717. aktfilepos:=left.fileinfo;
  718. CGMessage(parser_e_wrong_parameter_size);
  719. aktcallprocsym.write_parameter_lists(nil);
  720. end;
  721. goto errorexit;
  722. end;
  723. { now we can compare parameter after parameter }
  724. pt:=tcallparanode(left);
  725. { we start with the last parameter }
  726. lastpara:=paralength+1;
  727. lastparatype:=nil;
  728. while assigned(pt) do
  729. begin
  730. dec(lastpara);
  731. { walk all procedures and determine how this parameter matches and set:
  732. 1. pt.exact_match_found if one parameter has an exact match
  733. 2. exactmatch if an equal or exact match is found
  734. 3. Para.argconvtyp to exact,equal or convertable
  735. (when convertable then also convertlevel is set)
  736. 4. pt.convlevel1found if there is a convertlevel=1
  737. 5. pt.convlevel2found if there is a convertlevel=2
  738. }
  739. exactmatch:=false;
  740. hp:=procs;
  741. while assigned(hp) do
  742. begin
  743. if is_equal(pt,hp^.nextPara.paratype.def) then
  744. begin
  745. if hp^.nextPara.paratype.def=pt.resulttype.def then
  746. begin
  747. include(pt.callparaflags,cpf_exact_match_found);
  748. hp^.nextPara.argconvtyp:=act_exact;
  749. end
  750. else
  751. hp^.nextPara.argconvtyp:=act_equal;
  752. exactmatch:=true;
  753. end
  754. else
  755. begin
  756. hp^.nextPara.argconvtyp:=act_convertable;
  757. hp^.nextPara.convertlevel:=isconvertable(pt.resulttype.def,hp^.nextPara.paratype.def,
  758. hcvt,pt.left.nodetype,false);
  759. case hp^.nextPara.convertlevel of
  760. 1 : include(pt.callparaflags,cpf_convlevel1found);
  761. 2 : include(pt.callparaflags,cpf_convlevel2found);
  762. end;
  763. end;
  764. hp:=hp^.next;
  765. end;
  766. { If there was an exactmatch then delete all convertables }
  767. if exactmatch then
  768. begin
  769. hp:=procs;
  770. procs:=nil;
  771. while assigned(hp) do
  772. begin
  773. hp2:=hp^.next;
  774. { keep if not convertable }
  775. if (hp^.nextPara.argconvtyp<>act_convertable) then
  776. begin
  777. hp^.next:=procs;
  778. procs:=hp;
  779. end
  780. else
  781. dispose(hp);
  782. hp:=hp2;
  783. end;
  784. end
  785. else
  786. { No exact match was found, remove all procedures that are
  787. not convertable (convertlevel=0) }
  788. begin
  789. hp:=procs;
  790. procs:=nil;
  791. while assigned(hp) do
  792. begin
  793. hp2:=hp^.next;
  794. { keep if not convertable }
  795. if (hp^.nextPara.convertlevel<>0) then
  796. begin
  797. hp^.next:=procs;
  798. procs:=hp;
  799. end
  800. else
  801. begin
  802. { save the type for nice error message }
  803. lastparatype:=hp^.nextPara.paratype.def;
  804. dispose(hp);
  805. end;
  806. hp:=hp2;
  807. end;
  808. end;
  809. { update nextpara for all procedures }
  810. hp:=procs;
  811. while assigned(hp) do
  812. begin
  813. hp^.nextpara:=tparaitem(hp^.nextPara.next);
  814. hp:=hp^.next;
  815. end;
  816. { load next parameter or quit loop if no procs left }
  817. if assigned(procs) then
  818. pt:=tcallparanode(pt.right)
  819. else
  820. break;
  821. end;
  822. { All parameters are checked, check if there are any
  823. procedures left }
  824. if not assigned(procs) then
  825. begin
  826. { there is an error, must be wrong type, because
  827. wrong size is already checked (PFV) }
  828. if (not assigned(lastparatype)) or
  829. (not assigned(pt)) or
  830. (not assigned(pt.resulttype.def)) then
  831. internalerror(39393)
  832. else
  833. begin
  834. aktfilepos:=pt.fileinfo;
  835. CGMessage3(type_e_wrong_parameter_type,tostr(lastpara),
  836. pt.resulttype.def.typename,lastparatype.typename);
  837. end;
  838. aktcallprocsym.write_parameter_lists(nil);
  839. goto errorexit;
  840. end;
  841. { if there are several choices left then for orddef }
  842. { if a type is totally included in the other }
  843. { we don't fear an overflow , }
  844. { so we can do as if it is an exact match }
  845. { this will convert integer to longint }
  846. { rather than to words }
  847. { conversion of byte to integer or longint }
  848. {would still not be solved }
  849. if assigned(procs) and assigned(procs^.next) then
  850. begin
  851. hp:=procs;
  852. while assigned(hp) do
  853. begin
  854. hp^.nextpara:=hp^.firstpara;
  855. hp:=hp^.next;
  856. end;
  857. pt:=tcallparanode(left);
  858. while assigned(pt) do
  859. begin
  860. { matches a parameter of one procedure exact ? }
  861. exactmatch:=false;
  862. def_from:=pt.resulttype.def;
  863. hp:=procs;
  864. while assigned(hp) do
  865. begin
  866. if not is_equal(pt,hp^.nextPara.paratype.def) then
  867. begin
  868. def_to:=hp^.nextPara.paratype.def;
  869. if ((def_from.deftype=orddef) and (def_to.deftype=orddef)) and
  870. (is_in_limit(def_from,def_to) or
  871. ((hp^.nextPara.paratyp in [vs_var,vs_out]) and
  872. (def_from.size=def_to.size))) then
  873. begin
  874. exactmatch:=true;
  875. conv_to:=def_to;
  876. end;
  877. end;
  878. hp:=hp^.next;
  879. end;
  880. { .... if yes, del all the other procedures }
  881. if exactmatch then
  882. begin
  883. { the first .... }
  884. while (assigned(procs)) and not(is_in_limit(def_from,procs^.nextPara.paratype.def)) do
  885. begin
  886. hp:=procs^.next;
  887. dispose(procs);
  888. procs:=hp;
  889. end;
  890. { and the others }
  891. hp:=procs;
  892. while (assigned(hp)) and assigned(hp^.next) do
  893. begin
  894. if not(is_in_limit(def_from,hp^.next^.nextPara.paratype.def)) then
  895. begin
  896. hp2:=hp^.next^.next;
  897. dispose(hp^.next);
  898. hp^.next:=hp2;
  899. end
  900. else
  901. begin
  902. def_to:=hp^.next^.nextPara.paratype.def;
  903. if (conv_to.size>def_to.size) or
  904. ((torddef(conv_to).low<torddef(def_to).low) and
  905. (torddef(conv_to).high>torddef(def_to).high)) then
  906. begin
  907. hp2:=procs;
  908. procs:=hp;
  909. conv_to:=def_to;
  910. dispose(hp2);
  911. end
  912. else
  913. hp:=hp^.next;
  914. end;
  915. end;
  916. end;
  917. { update nextpara for all procedures }
  918. hp:=procs;
  919. while assigned(hp) do
  920. begin
  921. hp^.nextpara:=tparaitem(hp^.nextPara.next);
  922. hp:=hp^.next;
  923. end;
  924. pt:=tcallparanode(pt.right);
  925. end;
  926. end;
  927. { let's try to eliminate equal if there is an exact match
  928. is there }
  929. if assigned(procs) and assigned(procs^.next) then
  930. begin
  931. { reset nextpara for all procs left }
  932. hp:=procs;
  933. while assigned(hp) do
  934. begin
  935. hp^.nextpara:=hp^.firstpara;
  936. hp:=hp^.next;
  937. end;
  938. pt:=tcallparanode(left);
  939. while assigned(pt) do
  940. begin
  941. if cpf_exact_match_found in pt.callparaflags then
  942. begin
  943. hp:=procs;
  944. procs:=nil;
  945. while assigned(hp) do
  946. begin
  947. hp2:=hp^.next;
  948. { keep the exact matches, dispose the others }
  949. if (hp^.nextPara.argconvtyp=act_exact) then
  950. begin
  951. hp^.next:=procs;
  952. procs:=hp;
  953. end
  954. else
  955. dispose(hp);
  956. hp:=hp2;
  957. end;
  958. end;
  959. { update nextpara for all procedures }
  960. hp:=procs;
  961. while assigned(hp) do
  962. begin
  963. hp^.nextpara:=tparaitem(hp^.nextPara.next);
  964. hp:=hp^.next;
  965. end;
  966. pt:=tcallparanode(pt.right);
  967. end;
  968. end;
  969. { Check if there are integer constant to integer
  970. parameters then choose the best matching integer
  971. parameter and remove the others, this is Delphi
  972. compatible. 1 = byte, 256 = word, etc. }
  973. if assigned(procs) and assigned(procs^.next) then
  974. begin
  975. { reset nextpara for all procs left }
  976. hp:=procs;
  977. while assigned(hp) do
  978. begin
  979. hp^.nextpara:=hp^.firstpara;
  980. hp:=hp^.next;
  981. end;
  982. pt:=tcallparanode(left);
  983. while assigned(pt) do
  984. begin
  985. bestord:=nil;
  986. if (pt.left.nodetype=ordconstn) and
  987. is_integer(pt.resulttype.def) then
  988. begin
  989. hp:=procs;
  990. while assigned(hp) do
  991. begin
  992. def_to:=hp^.nextPara.paratype.def;
  993. { to be sure, it couldn't be something else,
  994. also the defs here are all in the range
  995. so now find the closest range }
  996. if not is_integer(def_to) then
  997. internalerror(43297815);
  998. if (not assigned(bestord)) or
  999. ((torddef(def_to).low>bestord.low) or
  1000. (torddef(def_to).high<bestord.high)) then
  1001. bestord:=torddef(def_to);
  1002. hp:=hp^.next;
  1003. end;
  1004. end;
  1005. { if a bestmatch is found then remove the other
  1006. procs which don't match the bestord }
  1007. if assigned(bestord) then
  1008. begin
  1009. hp:=procs;
  1010. procs:=nil;
  1011. while assigned(hp) do
  1012. begin
  1013. hp2:=hp^.next;
  1014. { keep matching bestord, dispose the others }
  1015. if (torddef(hp^.nextPara.paratype.def)=bestord) then
  1016. begin
  1017. hp^.next:=procs;
  1018. procs:=hp;
  1019. end
  1020. else
  1021. dispose(hp);
  1022. hp:=hp2;
  1023. end;
  1024. end;
  1025. { update nextpara for all procedures }
  1026. hp:=procs;
  1027. while assigned(hp) do
  1028. begin
  1029. hp^.nextpara:=tparaitem(hp^.nextPara.next);
  1030. hp:=hp^.next;
  1031. end;
  1032. pt:=tcallparanode(pt.right);
  1033. end;
  1034. end;
  1035. { Check if there are convertlevel 1 and 2 differences
  1036. left for the parameters, then discard all convertlevel
  1037. 2 procedures. The value of convlevelXfound can still
  1038. be used, because all convertables are still here or
  1039. not }
  1040. if assigned(procs) and assigned(procs^.next) then
  1041. begin
  1042. { reset nextpara for all procs left }
  1043. hp:=procs;
  1044. while assigned(hp) do
  1045. begin
  1046. hp^.nextpara:=hp^.firstpara;
  1047. hp:=hp^.next;
  1048. end;
  1049. pt:=tcallparanode(left);
  1050. while assigned(pt) do
  1051. begin
  1052. if (cpf_convlevel1found in pt.callparaflags) and
  1053. (cpf_convlevel2found in pt.callparaflags) then
  1054. begin
  1055. hp:=procs;
  1056. procs:=nil;
  1057. while assigned(hp) do
  1058. begin
  1059. hp2:=hp^.next;
  1060. { keep all not act_convertable and all convertlevels=1 }
  1061. if (hp^.nextPara.argconvtyp<>act_convertable) or
  1062. (hp^.nextPara.convertlevel=1) then
  1063. begin
  1064. hp^.next:=procs;
  1065. procs:=hp;
  1066. end
  1067. else
  1068. dispose(hp);
  1069. hp:=hp2;
  1070. end;
  1071. end;
  1072. { update nextpara for all procedures }
  1073. hp:=procs;
  1074. while assigned(hp) do
  1075. begin
  1076. hp^.nextpara:=tparaitem(hp^.nextPara.next);
  1077. hp:=hp^.next;
  1078. end;
  1079. pt:=tcallparanode(pt.right);
  1080. end;
  1081. end;
  1082. if not(assigned(procs)) or assigned(procs^.next) then
  1083. begin
  1084. CGMessage(cg_e_cant_choose_overload_function);
  1085. aktcallprocsym.write_parameter_lists(nil);
  1086. goto errorexit;
  1087. end;
  1088. {$ifdef TEST_PROCSYMS}
  1089. if (procs=nil) and assigned(nextprocsym) then
  1090. begin
  1091. symtableprocentry:=nextprocsym;
  1092. symtableproc:=symt;
  1093. end;
  1094. end ; { of while assigned(symtableprocentry) do }
  1095. {$endif TEST_PROCSYMS}
  1096. if make_ref then
  1097. begin
  1098. procs^.data.lastref:=tref.create(procs^.data.lastref,@fileinfo);
  1099. inc(procs^.data.refcount);
  1100. if procs^.data.defref=nil then
  1101. procs^.data.defref:=procs^.data.lastref;
  1102. end;
  1103. procdefinition:=procs^.data;
  1104. { big error for with statements
  1105. symtableproc:=procdefinition.owner;
  1106. but neede for overloaded operators !! }
  1107. if symtableproc=nil then
  1108. symtableproc:=procdefinition.owner;
  1109. {$ifdef CHAINPROCSYMS}
  1110. { object with method read;
  1111. call to read(x) will be a usual procedure call }
  1112. if assigned(methodpointer) and
  1113. (procdefinition._class=nil) then
  1114. begin
  1115. { not ok for extended }
  1116. case methodpointer^.nodetype of
  1117. typen,hnewn : fatalerror(no_para_match);
  1118. end;
  1119. methodpointer.free;
  1120. methodpointer:=nil;
  1121. end;
  1122. {$endif CHAINPROCSYMS}
  1123. end; { end of procedure to call determination }
  1124. { add needed default parameters }
  1125. if assigned(procs) and
  1126. (paralength<procdefinition.maxparacount) then
  1127. begin
  1128. { add default parameters, just read back the skipped
  1129. paras starting from firstPara.previous, when not available
  1130. (all parameters are default) then start with the last
  1131. parameter and read backward (PFV) }
  1132. if not assigned(procs^.firstpara) then
  1133. pdc:=tparaitem(procs^.data.Para.last)
  1134. else
  1135. pdc:=tparaitem(procs^.firstPara.previous);
  1136. while assigned(pdc) do
  1137. begin
  1138. if not assigned(pdc.defaultvalue) then
  1139. internalerror(751349858);
  1140. left:=ccallparanode.create(genconstsymtree(tconstsym(pdc.defaultvalue)),left);
  1141. pdc:=tparaitem(pdc.previous);
  1142. end;
  1143. end;
  1144. end;
  1145. { handle predefined procedures }
  1146. is_const:=(pocall_internconst in procdefinition.proccalloptions) and
  1147. ((block_type in [bt_const,bt_type]) or
  1148. (assigned(left) and (tcallparanode(left).left.nodetype in [realconstn,ordconstn])));
  1149. if (pocall_internproc in procdefinition.proccalloptions) or is_const then
  1150. begin
  1151. if assigned(left) then
  1152. begin
  1153. { ptr and settextbuf needs two args }
  1154. if assigned(tcallparanode(left).right) then
  1155. begin
  1156. hpt:=geninlinenode(tprocdef(procdefinition).extnumber,is_const,left);
  1157. left:=nil;
  1158. end
  1159. else
  1160. begin
  1161. hpt:=geninlinenode(tprocdef(procdefinition).extnumber,is_const,tcallparanode(left).left);
  1162. tcallparanode(left).left:=nil;
  1163. end;
  1164. end
  1165. else
  1166. hpt:=geninlinenode(tprocdef(procdefinition).extnumber,is_const,nil);
  1167. resulttypepass(hpt);
  1168. result:=hpt;
  1169. goto errorexit;
  1170. end;
  1171. { Calling a message method directly ? }
  1172. if assigned(procdefinition) and
  1173. (po_containsself in procdefinition.procoptions) then
  1174. message(cg_e_cannot_call_message_direct);
  1175. { ensure that the result type is set }
  1176. resulttype:=procdefinition.rettype;
  1177. { constructors return their current class type, not the type where the
  1178. constructor is declared, this can be different because of inheritance }
  1179. if (procdefinition.proctypeoption=potype_constructor) then
  1180. begin
  1181. if assigned(methodpointer) and
  1182. assigned(methodpointer.resulttype.def) and
  1183. (methodpointer.resulttype.def.deftype=classrefdef) then
  1184. resulttype:=tclassrefdef(methodpointer.resulttype.def).pointertype;
  1185. end;
  1186. { insert type conversions }
  1187. if assigned(left) then
  1188. tcallparanode(left).insert_typeconv(tparaitem(procdefinition.Para.first),true);
  1189. errorexit:
  1190. { Reset some settings back }
  1191. if assigned(procs) then
  1192. dispose(procs);
  1193. aktcallprocsym:=oldcallprocsym;
  1194. end;
  1195. function tcallnode.pass_1 : tnode;
  1196. var
  1197. inlinecode : tnode;
  1198. inlined : boolean;
  1199. {$ifdef m68k}
  1200. regi : tregister;
  1201. {$endif}
  1202. method_must_be_valid : boolean;
  1203. label
  1204. errorexit;
  1205. begin
  1206. result:=nil;
  1207. inlined:=false;
  1208. { work trough all parameters to get the register requirements }
  1209. if assigned(left) then
  1210. tcallparanode(left).det_registers;
  1211. if assigned(procdefinition) and
  1212. (pocall_inline in procdefinition.proccalloptions) then
  1213. begin
  1214. inlinecode:=right;
  1215. if assigned(inlinecode) then
  1216. begin
  1217. inlined:=true;
  1218. exclude(procdefinition.proccalloptions,pocall_inline);
  1219. end;
  1220. right:=nil;
  1221. end;
  1222. { procedure variable ? }
  1223. if assigned(right) then
  1224. begin
  1225. firstpass(right);
  1226. { procedure does a call }
  1227. if not (block_type in [bt_const,bt_type]) then
  1228. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1229. {$ifndef newcg}
  1230. { calc the correture value for the register }
  1231. {$ifdef i386}
  1232. incrementregisterpushed($ff);
  1233. {$endif}
  1234. {$ifdef m68k}
  1235. for regi:=R_D0 to R_A6 do
  1236. inc(reg_pushes[regi],t_times*2);
  1237. {$endif}
  1238. {$endif newcg}
  1239. end
  1240. else
  1241. { not a procedure variable }
  1242. begin
  1243. location.loc:=LOC_MEM;
  1244. { calc the correture value for the register }
  1245. { handle predefined procedures }
  1246. if (pocall_inline in procdefinition.proccalloptions) then
  1247. begin
  1248. if assigned(methodpointer) then
  1249. CGMessage(cg_e_unable_inline_object_methods);
  1250. if assigned(right) and (right.nodetype<>procinlinen) then
  1251. CGMessage(cg_e_unable_inline_procvar);
  1252. { nodetype:=procinlinen; }
  1253. if not assigned(right) then
  1254. begin
  1255. if assigned(tprocdef(procdefinition).code) then
  1256. inlinecode:=cprocinlinenode.create(self,tnode(tprocdef(procdefinition).code))
  1257. else
  1258. CGMessage(cg_e_no_code_for_inline_stored);
  1259. if assigned(inlinecode) then
  1260. begin
  1261. { consider it has not inlined if called
  1262. again inside the args }
  1263. exclude(procdefinition.proccalloptions,pocall_inline);
  1264. firstpass(inlinecode);
  1265. inlined:=true;
  1266. end;
  1267. end;
  1268. end
  1269. else
  1270. begin
  1271. if not (block_type in [bt_const,bt_type]) then
  1272. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1273. end;
  1274. {$ifndef newcg}
  1275. {$ifdef i386}
  1276. incrementregisterpushed(tprocdef(procdefinition).usedregisters);
  1277. {$endif}
  1278. {$ifdef m68k}
  1279. for regi:=R_D0 to R_A6 do
  1280. begin
  1281. if (tprocdef(procdefinition).usedregisters and ($800 shr word(regi)))<>0 then
  1282. inc(reg_pushes[regi],t_times*2);
  1283. end;
  1284. {$endif}
  1285. {$endif newcg}
  1286. end;
  1287. { get a register for the return value }
  1288. if (not is_void(resulttype.def)) then
  1289. begin
  1290. if (procdefinition.proctypeoption=potype_constructor) then
  1291. begin
  1292. { extra handling of classes }
  1293. { methodpointer should be assigned! }
  1294. if assigned(methodpointer) and
  1295. assigned(methodpointer.resulttype.def) and
  1296. (methodpointer.resulttype.def.deftype=classrefdef) then
  1297. begin
  1298. location.loc:=LOC_REGISTER;
  1299. registers32:=1;
  1300. end
  1301. { a object constructor returns the result with the flags }
  1302. else
  1303. location.loc:=LOC_FLAGS;
  1304. end
  1305. else
  1306. begin
  1307. {$ifdef SUPPORT_MMX}
  1308. if (cs_mmx in aktlocalswitches) and
  1309. is_mmx_able_array(resulttype.def) then
  1310. begin
  1311. location.loc:=LOC_MMXREGISTER;
  1312. registersmmx:=1;
  1313. end
  1314. else
  1315. {$endif SUPPORT_MMX}
  1316. if ret_in_acc(resulttype.def) then
  1317. begin
  1318. location.loc:=LOC_REGISTER;
  1319. if is_64bitint(resulttype.def) then
  1320. registers32:=2
  1321. else
  1322. registers32:=1;
  1323. { wide- and ansistrings are returned in EAX }
  1324. { but they are imm. moved to a memory location }
  1325. if is_widestring(resulttype.def) or
  1326. is_ansistring(resulttype.def) then
  1327. begin
  1328. location.loc:=LOC_MEM;
  1329. { this is wrong we still need one register PM
  1330. registers32:=0; }
  1331. { we use ansistrings so no fast exit here }
  1332. procinfo^.no_fast_exit:=true;
  1333. registers32:=1;
  1334. end;
  1335. end
  1336. else if (resulttype.def.deftype=floatdef) then
  1337. begin
  1338. location.loc:=LOC_FPU;
  1339. registersfpu:=1;
  1340. end
  1341. else
  1342. location.loc:=LOC_MEM;
  1343. end;
  1344. end;
  1345. { a fpu can be used in any procedure !! }
  1346. registersfpu:=procdefinition.fpu_used;
  1347. { if this is a call to a method calc the registers }
  1348. if (methodpointer<>nil) then
  1349. begin
  1350. case methodpointer.nodetype of
  1351. { but only, if this is not a supporting node }
  1352. typen: ;
  1353. { we need one register for new return value PM }
  1354. hnewn : if registers32=0 then
  1355. registers32:=1;
  1356. else
  1357. begin
  1358. if (procdefinition.proctypeoption in [potype_constructor,potype_destructor]) and
  1359. assigned(symtableproc) and (symtableproc.symtabletype=withsymtable) and
  1360. not twithsymtable(symtableproc).direct_with then
  1361. begin
  1362. CGmessage(cg_e_cannot_call_cons_dest_inside_with);
  1363. end; { Is accepted by Delphi !! }
  1364. { this is not a good reason to accept it in FPC if we produce
  1365. wrong code for it !!! (PM) }
  1366. { R.Assign is not a constructor !!! }
  1367. { but for R^.Assign, R must be valid !! }
  1368. if (procdefinition.proctypeoption=potype_constructor) or
  1369. ((methodpointer.nodetype=loadn) and
  1370. (not(oo_has_virtual in tobjectdef(methodpointer.resulttype.def).objectoptions))) then
  1371. method_must_be_valid:=false
  1372. else
  1373. method_must_be_valid:=true;
  1374. firstpass(methodpointer);
  1375. set_varstate(methodpointer,method_must_be_valid);
  1376. { The object is already used ven if it is called once }
  1377. if (methodpointer.nodetype=loadn) and
  1378. (tloadnode(methodpointer).symtableentry.typ=varsym) then
  1379. tvarsym(tloadnode(methodpointer).symtableentry).varstate:=vs_used;
  1380. registersfpu:=max(methodpointer.registersfpu,registersfpu);
  1381. registers32:=max(methodpointer.registers32,registers32);
  1382. {$ifdef SUPPORT_MMX}
  1383. registersmmx:=max(methodpointer.registersmmx,registersmmx);
  1384. {$endif SUPPORT_MMX}
  1385. end;
  1386. end;
  1387. end;
  1388. if inlined then
  1389. right:=inlinecode;
  1390. { determine the registers of the procedure variable }
  1391. { is this OK for inlined procs also ?? (PM) }
  1392. if assigned(right) then
  1393. begin
  1394. registersfpu:=max(right.registersfpu,registersfpu);
  1395. registers32:=max(right.registers32,registers32);
  1396. {$ifdef SUPPORT_MMX}
  1397. registersmmx:=max(right.registersmmx,registersmmx);
  1398. {$endif SUPPORT_MMX}
  1399. end;
  1400. { determine the registers of the procedure }
  1401. if assigned(left) then
  1402. begin
  1403. registersfpu:=max(left.registersfpu,registersfpu);
  1404. registers32:=max(left.registers32,registers32);
  1405. {$ifdef SUPPORT_MMX}
  1406. registersmmx:=max(left.registersmmx,registersmmx);
  1407. {$endif SUPPORT_MMX}
  1408. end;
  1409. errorexit:
  1410. if inlined then
  1411. include(procdefinition.proccalloptions,pocall_inline);
  1412. end;
  1413. function tcallnode.docompare(p: tnode): boolean;
  1414. begin
  1415. docompare :=
  1416. inherited docompare(p) and
  1417. (symtableprocentry = tcallnode(p).symtableprocentry) and
  1418. (symtableproc = tcallnode(p).symtableproc) and
  1419. (procdefinition = tcallnode(p).procdefinition) and
  1420. (methodpointer = tcallnode(p).methodpointer);
  1421. end;
  1422. {****************************************************************************
  1423. TPROCINLINENODE
  1424. ****************************************************************************}
  1425. constructor tprocinlinenode.create(callp,code : tnode);
  1426. begin
  1427. inherited create(procinlinen);
  1428. inlineprocsym:=tcallnode(callp).symtableprocentry;
  1429. retoffset:=-target_os.size_of_pointer; { less dangerous as zero (PM) }
  1430. para_offset:=0;
  1431. para_size:=inlineprocsym.definition.para_size(target_os.stackalignment);
  1432. if ret_in_param(inlineprocsym.definition.rettype.def) then
  1433. para_size:=para_size+target_os.size_of_pointer;
  1434. { copy args }
  1435. if assigned(code) then
  1436. inlinetree:=code.getcopy
  1437. else inlinetree := nil;
  1438. registers32:=code.registers32;
  1439. registersfpu:=code.registersfpu;
  1440. {$ifdef SUPPORT_MMX}
  1441. registersmmx:=code.registersmmx;
  1442. {$endif SUPPORT_MMX}
  1443. resulttype:=inlineprocsym.definition.rettype;
  1444. end;
  1445. destructor tprocinlinenode.destroy;
  1446. begin
  1447. if assigned(inlinetree) then
  1448. inlinetree.free;
  1449. inherited destroy;
  1450. end;
  1451. function tprocinlinenode.getcopy : tnode;
  1452. var
  1453. n : tprocinlinenode;
  1454. begin
  1455. n:=tprocinlinenode(inherited getcopy);
  1456. if assigned(inlinetree) then
  1457. n.inlinetree:=inlinetree.getcopy
  1458. else
  1459. n.inlinetree:=nil;
  1460. n.inlineprocsym:=inlineprocsym;
  1461. n.retoffset:=retoffset;
  1462. n.para_offset:=para_offset;
  1463. n.para_size:=para_size;
  1464. getcopy:=n;
  1465. end;
  1466. procedure tprocinlinenode.insertintolist(l : tnodelist);
  1467. begin
  1468. end;
  1469. function tprocinlinenode.pass_1 : tnode;
  1470. begin
  1471. result:=nil;
  1472. { left contains the code in tree form }
  1473. { but it has already been firstpassed }
  1474. { so firstpass(left); does not seem required }
  1475. { might be required later if we change the arg handling !! }
  1476. end;
  1477. function tprocinlinenode.docompare(p: tnode): boolean;
  1478. begin
  1479. docompare :=
  1480. inherited docompare(p) and
  1481. inlinetree.isequal(tprocinlinenode(p).inlinetree) and
  1482. (inlineprocsym = tprocinlinenode(p).inlineprocsym);
  1483. end;
  1484. begin
  1485. ccallnode:=tcallnode;
  1486. ccallparanode:=tcallparanode;
  1487. cprocinlinenode:=tprocinlinenode;
  1488. end.
  1489. {
  1490. $Log$
  1491. Revision 1.29 2001-04-13 23:52:29 peter
  1492. * don't allow passing signed-unsigned ords to var parameter, this
  1493. forbids smallint-word, shortint-byte, longint-cardinal mixtures.
  1494. It's still allowed in tp7 -So mode.
  1495. Revision 1.28 2001/04/13 22:22:59 peter
  1496. * call set_varstate for procvar calls
  1497. Revision 1.27 2001/04/13 01:22:08 peter
  1498. * symtable change to classes
  1499. * range check generation and errors fixed, make cycle DEBUG=1 works
  1500. * memory leaks fixed
  1501. Revision 1.26 2001/04/04 22:42:39 peter
  1502. * move constant folding into det_resulttype
  1503. Revision 1.25 2001/04/02 21:20:30 peter
  1504. * resulttype rewrite
  1505. Revision 1.24 2001/03/12 12:47:46 michael
  1506. + Patches from peter
  1507. Revision 1.23 2001/02/26 19:44:52 peter
  1508. * merged generic m68k updates from fixes branch
  1509. Revision 1.22 2001/01/08 21:46:46 peter
  1510. * don't push high value for open array with cdecl;external;
  1511. Revision 1.21 2000/12/31 11:14:10 jonas
  1512. + implemented/fixed docompare() mathods for all nodes (not tested)
  1513. + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings
  1514. and constant strings/chars together
  1515. * n386add.pas: don't copy temp strings (of size 256) to another temp string
  1516. when adding
  1517. Revision 1.20 2000/12/25 00:07:26 peter
  1518. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  1519. tlinkedlist objects)
  1520. Revision 1.19 2000/12/17 14:35:12 peter
  1521. * fixed crash with procvar load in tp mode
  1522. Revision 1.18 2000/11/29 00:30:32 florian
  1523. * unused units removed from uses clause
  1524. * some changes for widestrings
  1525. Revision 1.17 2000/11/22 15:12:06 jonas
  1526. * fixed inline-related problems (partially "merges")
  1527. Revision 1.16 2000/11/11 16:14:52 peter
  1528. * fixed crash with settextbuf,ptr
  1529. Revision 1.15 2000/11/06 21:36:25 peter
  1530. * fixed var parameter varstate bug
  1531. Revision 1.14 2000/11/04 14:25:20 florian
  1532. + merged Attila's changes for interfaces, not tested yet
  1533. Revision 1.13 2000/10/31 22:02:47 peter
  1534. * symtable splitted, no real code changes
  1535. Revision 1.12 2000/10/21 18:16:11 florian
  1536. * a lot of changes:
  1537. - basic dyn. array support
  1538. - basic C++ support
  1539. - some work for interfaces done
  1540. ....
  1541. Revision 1.11 2000/10/21 14:35:27 peter
  1542. * readd to many remove p. for tcallnode.is_equal()
  1543. Revision 1.10 2000/10/14 21:52:55 peter
  1544. * fixed memory leaks
  1545. Revision 1.9 2000/10/14 10:14:50 peter
  1546. * moehrendorf oct 2000 rewrite
  1547. Revision 1.8 2000/10/01 19:48:24 peter
  1548. * lot of compile updates for cg11
  1549. Revision 1.7 2000/09/28 19:49:52 florian
  1550. *** empty log message ***
  1551. Revision 1.6 2000/09/27 18:14:31 florian
  1552. * fixed a lot of syntax errors in the n*.pas stuff
  1553. Revision 1.5 2000/09/24 21:15:34 florian
  1554. * some errors fix to get more stuff compilable
  1555. Revision 1.4 2000/09/24 20:17:44 florian
  1556. * more conversion work done
  1557. Revision 1.3 2000/09/24 15:06:19 peter
  1558. * use defines.inc
  1559. Revision 1.2 2000/09/20 21:52:38 florian
  1560. * removed a lot of errors
  1561. Revision 1.1 2000/09/20 20:52:16 florian
  1562. * initial revision
  1563. }