ncal.pas 67 KB

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