ncal.pas 67 KB

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