ncal.pas 65 KB

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