ncal.pas 64 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 by Florian Klaempfl
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit ncal;
  18. {$i defines.inc}
  19. interface
  20. uses
  21. node,symtable;
  22. type
  23. tcallnode = class(tbinarynode)
  24. { the symbol containing the definition of the procedure }
  25. { to call }
  26. symtableprocentry : pprocsym;
  27. { the symtable containing symtableprocentry }
  28. symtableproc : psymtable;
  29. { the definition of the procedure to call }
  30. procdefinition : pabstractprocdef;
  31. methodpointer : tnode;
  32. { only the processor specific nodes need to override this }
  33. { constructor }
  34. constructor create(v : pprocsym;st : psymtable; mp : tnode);virtual;
  35. destructor destroy;override;
  36. function getcopy : tnode;override;
  37. function pass_1 : tnode;override;
  38. end;
  39. tcallparaflags = (
  40. { flags used by tcallparanode }
  41. cpf_exact_match_found,
  42. cpf_convlevel1found,
  43. cpf_convlevel2found,
  44. cpf_is_colon_para
  45. );
  46. tcallparanode = class(tbinarynode)
  47. callparaflags : set of tcallparaflags;
  48. hightree : tnode;
  49. { only the processor specific nodes need to override this }
  50. { constructor }
  51. constructor create(expr,next : tnode);virtual;
  52. destructor destroy;override;
  53. function getcopy : tnode;override;
  54. procedure gen_high_tree(openstring:boolean);
  55. { tcallparanode doesn't use pass_1 }
  56. { tcallnode takes care of this }
  57. procedure firstcallparan(defcoll : pparaitem;do_count : boolean);virtual;
  58. procedure secondcallparan(defcoll : pparaitem;
  59. push_from_left_to_right,inlined,is_cdecl : boolean;
  60. para_alignment,para_offset : longint);virtual;abstract;
  61. end;
  62. tprocinlinenode = class(tnode)
  63. inlinetree : tnode;
  64. inlineprocsym : pprocsym;
  65. retoffset,para_offset,para_size : longint;
  66. constructor create(callp,code : tnode);virtual;
  67. destructor destroy;override;
  68. function getcopy : tnode;override;
  69. function pass_1 : tnode;override;
  70. end;
  71. function gencallparanode(expr,next : tnode) : tnode;
  72. function gencallnode(v : pprocsym;st : psymtable) : tnode;
  73. { uses the callnode to create the new procinline node }
  74. function genprocinlinenode(callp,code : tnode) : tnode;
  75. var
  76. ccallnode : class of tcallnode;
  77. ccallparanode : class of tcallparanode;
  78. cprocinlinenode : class of tprocinlinenode;
  79. implementation
  80. uses
  81. cutils,globtype,systems,
  82. cobjects,verbose,globals,
  83. symconst,aasm,types,
  84. htypechk,pass_1,cpubase,
  85. ncnv,nld,ninl,nadd,ncon
  86. {$ifdef newcg}
  87. ,cgbase
  88. ,tgobj
  89. {$else newcg}
  90. ,hcodegen
  91. {$ifdef i386}
  92. ,tgeni386
  93. {$endif}
  94. {$ifdef m68k}
  95. ,tgen68k
  96. {$endif m68k}
  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.firstcallparan(defcoll : pparaitem;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(pparaitem(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=vs_var) then
  220. set_funcret_is_valid(left);
  221. { protected has nothing to do with read/write
  222. if (defcoll^.paratyp=vs_var) 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. { Variablen 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=vs_var 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,defcoll^.paratyp <> vs_var);
  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. function tcallnode.pass_1 : tnode;
  477. type
  478. pprocdefcoll = ^tprocdefcoll;
  479. tprocdefcoll = record
  480. data : pprocdef;
  481. nextpara : pparaitem;
  482. firstpara : pparaitem;
  483. next : pprocdefcoll;
  484. end;
  485. var
  486. hp,procs,hp2 : pprocdefcoll;
  487. pd : pprocdef;
  488. oldcallprocsym : pprocsym;
  489. def_from,def_to,conv_to : pdef;
  490. hpt,pt,inlinecode : tnode;
  491. exactmatch,inlined : boolean;
  492. paralength,lastpara : longint;
  493. lastparatype : pdef;
  494. pdc : pparaitem;
  495. {$ifdef TEST_PROCSYMS}
  496. nextprocsym : pprocsym;
  497. symt : psymtable;
  498. {$endif TEST_PROCSYMS}
  499. { only Dummy }
  500. hcvt : tconverttype;
  501. {$ifdef m68k}
  502. regi : tregister;
  503. {$endif}
  504. method_must_be_valid : boolean;
  505. label
  506. errorexit;
  507. { check if the resulttype from tree p is equal with def, needed
  508. for stringconstn and formaldef }
  509. function is_equal(p:tnode;def:pdef) : boolean;
  510. begin
  511. { safety check }
  512. if not (assigned(def) or assigned(p.resulttype)) then
  513. begin
  514. is_equal:=false;
  515. exit;
  516. end;
  517. { all types can be passed to a formaldef }
  518. is_equal:=(def^.deftype=formaldef) or
  519. (types.is_equal(p.resulttype,def))
  520. { integer constants are compatible with all integer parameters if
  521. the specified value matches the range }
  522. or
  523. (
  524. (left.nodetype=ordconstn) and
  525. is_integer(p.resulttype) and
  526. is_integer(def) and
  527. (tordconstnode(left).value>=porddef(def)^.low) and
  528. (tordconstnode(left).value<=porddef(def)^.high)
  529. )
  530. { to support ansi/long/wide strings in a proper way }
  531. { string and string[10] are assumed as equal }
  532. { when searching the correct overloaded procedure }
  533. or
  534. (
  535. (def^.deftype=stringdef) and (p.resulttype^.deftype=stringdef) and
  536. (pstringdef(def)^.string_typ=pstringdef(p.resulttype)^.string_typ)
  537. )
  538. or
  539. (
  540. (left.nodetype=stringconstn) and
  541. (is_ansistring(p.resulttype) and is_pchar(def))
  542. )
  543. or
  544. (
  545. (left.nodetype=ordconstn) and
  546. (is_char(p.resulttype) and (is_shortstring(def) or is_ansistring(def)))
  547. )
  548. { set can also be a not yet converted array constructor }
  549. or
  550. (
  551. (def^.deftype=setdef) and (p.resulttype^.deftype=arraydef) and
  552. (parraydef(p.resulttype)^.IsConstructor) and not(parraydef(p.resulttype)^.IsVariant)
  553. )
  554. { in tp7 mode proc -> procvar is allowed }
  555. or
  556. (
  557. (m_tp_procvar in aktmodeswitches) and
  558. (def^.deftype=procvardef) and (left.nodetype=calln) and
  559. (proc_to_procvar_equal(pprocdef(tcallnode(left).procdefinition),pprocvardef(def)))
  560. )
  561. ;
  562. end;
  563. function is_in_limit(def_from,def_to : pdef) : boolean;
  564. begin
  565. is_in_limit:=(def_from^.deftype = orddef) and
  566. (def_to^.deftype = orddef) and
  567. (porddef(def_from)^.low>porddef(def_to)^.low) and
  568. (porddef(def_from)^.high<porddef(def_to)^.high);
  569. end;
  570. var
  571. is_const : boolean;
  572. i : longint;
  573. bestord : porddef;
  574. begin
  575. pass_1:=nil;
  576. { release registers! }
  577. { if procdefinition<>nil then we called firstpass already }
  578. { it seems to be bad because of the registers }
  579. { at least we can avoid the overloaded search !! }
  580. procs:=nil;
  581. { made this global for disposing !! }
  582. oldcallprocsym:=aktcallprocsym;
  583. aktcallprocsym:=nil;
  584. inlined:=false;
  585. if assigned(procdefinition) and
  586. (pocall_inline in procdefinition^.proccalloptions) then
  587. begin
  588. inlinecode:=right;
  589. if assigned(inlinecode) then
  590. begin
  591. inlined:=true;
  592. exclude(procdefinition^.proccalloptions,pocall_inline);
  593. end;
  594. right:=nil;
  595. end;
  596. if assigned(procdefinition) and
  597. (po_containsself in procdefinition^.procoptions) then
  598. message(cg_e_cannot_call_message_direct);
  599. { procedure variable ? }
  600. if assigned(right) then
  601. begin
  602. { procedure does a call }
  603. procinfo^.flags:=procinfo^.flags or pi_do_call;
  604. {$ifndef newcg}
  605. { calc the correture value for the register }
  606. {$ifdef i386}
  607. incrementregisterpushed($ff);
  608. {$endif}
  609. {$ifdef m68k}
  610. for regi:=R_D0 to R_A6 do
  611. inc(reg_pushes[regi],t_times*2);
  612. {$endif}
  613. {$endif newcg}
  614. { calculate the type of the parameters }
  615. if assigned(left) then
  616. begin
  617. tcallparanode(left).firstcallparan(nil,false);
  618. if codegenerror then
  619. goto errorexit;
  620. end;
  621. firstpass(right);
  622. set_varstate(right,true);
  623. { check the parameters }
  624. pdc:=pparaitem(pprocvardef(right.resulttype)^.para^.first);
  625. pt:=left;
  626. while assigned(pdc) and assigned(pt) do
  627. begin
  628. pt:=tcallparanode(pt).right;
  629. pdc:=pparaitem(pdc^.next);
  630. end;
  631. if assigned(pt) or assigned(pdc) then
  632. begin
  633. if assigned(pt) then
  634. aktfilepos:=pt.fileinfo;
  635. CGMessage(parser_e_illegal_parameter_list);
  636. end;
  637. { insert type conversions }
  638. if assigned(left) then
  639. begin
  640. tcallparanode(left).firstcallparan(pparaitem(pprocvardef(right.resulttype)^.para^.first),true);
  641. if codegenerror then
  642. goto errorexit;
  643. end;
  644. resulttype:=pprocvardef(right.resulttype)^.rettype.def;
  645. { this was missing, leads to a bug below if
  646. the procvar is a function }
  647. procdefinition:=pabstractprocdef(right.resulttype);
  648. end
  649. else
  650. { not a procedure variable }
  651. begin
  652. { determine the type of the parameters }
  653. if assigned(left) then
  654. begin
  655. tcallparanode(left).firstcallparan(nil,false);
  656. if codegenerror then
  657. goto errorexit;
  658. end;
  659. aktcallprocsym:=pprocsym(symtableprocentry);
  660. { do we know the procedure to call ? }
  661. if not(assigned(procdefinition)) then
  662. begin
  663. {$ifdef TEST_PROCSYMS}
  664. if (unit_specific) or
  665. assigned(methodpointer) then
  666. nextprocsym:=nil
  667. else while not assigned(procs) do
  668. begin
  669. symt:=symtableproc;
  670. srsym:=nil;
  671. while assigned(symt^.next) and not assigned(srsym) do
  672. begin
  673. symt:=symt^.next;
  674. getsymonlyin(symt,actprocsym^.name);
  675. if assigned(srsym) then
  676. if srsym^.typ<>procsym then
  677. begin
  678. { reject all that is not a procedure }
  679. srsym:=nil;
  680. { don't search elsewhere }
  681. while assigned(symt^.next) do
  682. symt:=symt^.next;
  683. end;
  684. end;
  685. nextprocsym:=srsym;
  686. end;
  687. {$endif TEST_PROCSYMS}
  688. { determine length of parameter list }
  689. pt:=left;
  690. paralength:=0;
  691. while assigned(pt) do
  692. begin
  693. inc(paralength);
  694. pt:=tcallparanode(pt).right;
  695. end;
  696. { link all procedures which have the same # of parameters }
  697. pd:=aktcallprocsym^.definition;
  698. while assigned(pd) do
  699. begin
  700. { only when the # of parameter are supported by the
  701. procedure }
  702. if (paralength>=pd^.minparacount) and (paralength<=pd^.maxparacount) then
  703. begin
  704. new(hp);
  705. hp^.data:=pd;
  706. hp^.next:=procs;
  707. hp^.firstpara:=pparaitem(pd^.para^.first);
  708. { if not all parameters are given, then skip the
  709. default parameters }
  710. for i:=1 to pd^.maxparacount-paralength do
  711. hp^.firstpara:=pparaitem(hp^.firstpara^.next);
  712. hp^.nextpara:=hp^.firstpara;
  713. procs:=hp;
  714. end;
  715. pd:=pd^.nextoverloaded;
  716. end;
  717. { no procedures found? then there is something wrong
  718. with the parameter size }
  719. if not assigned(procs) then
  720. begin
  721. { in tp mode we can try to convert to procvar if
  722. there are no parameters specified }
  723. if not(assigned(left)) and
  724. (m_tp_procvar in aktmodeswitches) then
  725. begin
  726. if (symtableprocentry^.owner^.symtabletype=objectsymtable) and
  727. (pobjectdef(symtableprocentry^.owner^.defowner)^.is_class) then
  728. hpt:=genloadmethodcallnode(pprocsym(symtableprocentry),symtableproc,
  729. methodpointer.getcopy)
  730. else
  731. hpt:=genloadcallnode(pprocsym(symtableprocentry),symtableproc);
  732. firstpass(hpt);
  733. pass_1:=hpt;
  734. end
  735. else
  736. begin
  737. if assigned(left) then
  738. aktfilepos:=left.fileinfo;
  739. CGMessage(parser_e_wrong_parameter_size);
  740. aktcallprocsym^.write_parameter_lists(nil);
  741. end;
  742. goto errorexit;
  743. end;
  744. { now we can compare parameter after parameter }
  745. pt:=left;
  746. { we start with the last parameter }
  747. lastpara:=paralength+1;
  748. lastparatype:=nil;
  749. while assigned(pt) do
  750. begin
  751. dec(lastpara);
  752. { walk all procedures and determine how this parameter matches and set:
  753. 1. pt.exact_match_found if one parameter has an exact match
  754. 2. exactmatch if an equal or exact match is found
  755. 3. para^.argconvtyp to exact,equal or convertable
  756. (when convertable then also convertlevel is set)
  757. 4. pt.convlevel1found if there is a convertlevel=1
  758. 5. pt.convlevel2found if there is a convertlevel=2
  759. }
  760. exactmatch:=false;
  761. hp:=procs;
  762. while assigned(hp) do
  763. begin
  764. if is_equal(pt,hp^.nextpara^.paratype.def) then
  765. begin
  766. if hp^.nextpara^.paratype.def=pt.resulttype then
  767. begin
  768. include(tcallparanode(pt).callparaflags,cpf_exact_match_found);
  769. hp^.nextpara^.argconvtyp:=act_exact;
  770. end
  771. else
  772. hp^.nextpara^.argconvtyp:=act_equal;
  773. exactmatch:=true;
  774. end
  775. else
  776. begin
  777. hp^.nextpara^.argconvtyp:=act_convertable;
  778. hp^.nextpara^.convertlevel:=isconvertable(pt.resulttype,hp^.nextpara^.paratype.def,
  779. hcvt,tcallparanode(pt).left.nodetype,false);
  780. case hp^.nextpara^.convertlevel of
  781. 1 : include(tcallparanode(pt).callparaflags,cpf_convlevel1found);
  782. 2 : include(tcallparanode(pt).callparaflags,cpf_convlevel2found);
  783. end;
  784. end;
  785. hp:=hp^.next;
  786. end;
  787. { If there was an exactmatch then delete all convertables }
  788. if exactmatch then
  789. begin
  790. hp:=procs;
  791. procs:=nil;
  792. while assigned(hp) do
  793. begin
  794. hp2:=hp^.next;
  795. { keep if not convertable }
  796. if (hp^.nextpara^.argconvtyp<>act_convertable) then
  797. begin
  798. hp^.next:=procs;
  799. procs:=hp;
  800. end
  801. else
  802. dispose(hp);
  803. hp:=hp2;
  804. end;
  805. end
  806. else
  807. { No exact match was found, remove all procedures that are
  808. not convertable (convertlevel=0) }
  809. begin
  810. hp:=procs;
  811. procs:=nil;
  812. while assigned(hp) do
  813. begin
  814. hp2:=hp^.next;
  815. { keep if not convertable }
  816. if (hp^.nextpara^.convertlevel<>0) then
  817. begin
  818. hp^.next:=procs;
  819. procs:=hp;
  820. end
  821. else
  822. begin
  823. { save the type for nice error message }
  824. lastparatype:=hp^.nextpara^.paratype.def;
  825. dispose(hp);
  826. end;
  827. hp:=hp2;
  828. end;
  829. end;
  830. { update nextpara for all procedures }
  831. hp:=procs;
  832. while assigned(hp) do
  833. begin
  834. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  835. hp:=hp^.next;
  836. end;
  837. { load next parameter or quit loop if no procs left }
  838. if assigned(procs) then
  839. pt:=tcallparanode(pt).right
  840. else
  841. break;
  842. end;
  843. { All parameters are checked, check if there are any
  844. procedures left }
  845. if not assigned(procs) then
  846. begin
  847. { there is an error, must be wrong type, because
  848. wrong size is already checked (PFV) }
  849. if (not assigned(lastparatype)) or
  850. (not assigned(pt)) or
  851. (not assigned(pt.resulttype)) then
  852. internalerror(39393)
  853. else
  854. begin
  855. aktfilepos:=pt.fileinfo;
  856. CGMessage3(type_e_wrong_parameter_type,tostr(lastpara),
  857. pt.resulttype^.typename,lastparatype^.typename);
  858. end;
  859. aktcallprocsym^.write_parameter_lists(nil);
  860. goto errorexit;
  861. end;
  862. { if there are several choices left then for orddef }
  863. { if a type is totally included in the other }
  864. { we don't fear an overflow , }
  865. { so we can do as if it is an exact match }
  866. { this will convert integer to longint }
  867. { rather than to words }
  868. { conversion of byte to integer or longint }
  869. {would still not be solved }
  870. if assigned(procs) and assigned(procs^.next) then
  871. begin
  872. hp:=procs;
  873. while assigned(hp) do
  874. begin
  875. hp^.nextpara:=hp^.firstpara;
  876. hp:=hp^.next;
  877. end;
  878. pt:=left;
  879. while assigned(pt) do
  880. begin
  881. { matches a parameter of one procedure exact ? }
  882. exactmatch:=false;
  883. def_from:=pt.resulttype;
  884. hp:=procs;
  885. while assigned(hp) do
  886. begin
  887. if not is_equal(pt,hp^.nextpara^.paratype.def) then
  888. begin
  889. def_to:=hp^.nextpara^.paratype.def;
  890. if ((def_from^.deftype=orddef) and (def_to^.deftype=orddef)) and
  891. (is_in_limit(def_from,def_to) or
  892. ((hp^.nextpara^.paratyp in [vs_var,vs_out]) and
  893. (def_from^.size=def_to^.size))) then
  894. begin
  895. exactmatch:=true;
  896. conv_to:=def_to;
  897. end;
  898. end;
  899. hp:=hp^.next;
  900. end;
  901. { .... if yes, del all the other procedures }
  902. if exactmatch then
  903. begin
  904. { the first .... }
  905. while (assigned(procs)) and not(is_in_limit(def_from,procs^.nextpara^.paratype.def)) do
  906. begin
  907. hp:=procs^.next;
  908. dispose(procs);
  909. procs:=hp;
  910. end;
  911. { and the others }
  912. hp:=procs;
  913. while (assigned(hp)) and assigned(hp^.next) do
  914. begin
  915. if not(is_in_limit(def_from,hp^.next^.nextpara^.paratype.def)) then
  916. begin
  917. hp2:=hp^.next^.next;
  918. dispose(hp^.next);
  919. hp^.next:=hp2;
  920. end
  921. else
  922. begin
  923. def_to:=hp^.next^.nextpara^.paratype.def;
  924. if (conv_to^.size>def_to^.size) or
  925. ((porddef(conv_to)^.low<porddef(def_to)^.low) and
  926. (porddef(conv_to)^.high>porddef(def_to)^.high)) then
  927. begin
  928. hp2:=procs;
  929. procs:=hp;
  930. conv_to:=def_to;
  931. dispose(hp2);
  932. end
  933. else
  934. hp:=hp^.next;
  935. end;
  936. end;
  937. end;
  938. { update nextpara for all procedures }
  939. hp:=procs;
  940. while assigned(hp) do
  941. begin
  942. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  943. hp:=hp^.next;
  944. end;
  945. pt:=tcallparanode(pt).right;
  946. end;
  947. end;
  948. { let's try to eliminate equal if there is an exact match
  949. is there }
  950. if assigned(procs) and assigned(procs^.next) then
  951. begin
  952. { reset nextpara for all procs left }
  953. hp:=procs;
  954. while assigned(hp) do
  955. begin
  956. hp^.nextpara:=hp^.firstpara;
  957. hp:=hp^.next;
  958. end;
  959. pt:=left;
  960. while assigned(pt) do
  961. begin
  962. if cpf_exact_match_found in tcallparanode(pt).callparaflags then
  963. begin
  964. hp:=procs;
  965. procs:=nil;
  966. while assigned(hp) do
  967. begin
  968. hp2:=hp^.next;
  969. { keep the exact matches, dispose the others }
  970. if (hp^.nextpara^.argconvtyp=act_exact) then
  971. begin
  972. hp^.next:=procs;
  973. procs:=hp;
  974. end
  975. else
  976. dispose(hp);
  977. hp:=hp2;
  978. end;
  979. end;
  980. { update nextpara for all procedures }
  981. hp:=procs;
  982. while assigned(hp) do
  983. begin
  984. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  985. hp:=hp^.next;
  986. end;
  987. pt:=tcallparanode(pt).right;
  988. end;
  989. end;
  990. { Check if there are integer constant to integer
  991. parameters then choose the best matching integer
  992. parameter and remove the others, this is Delphi
  993. compatible. 1 = byte, 256 = word, etc. }
  994. if assigned(procs) and assigned(procs^.next) then
  995. begin
  996. { reset nextpara for all procs left }
  997. hp:=procs;
  998. while assigned(hp) do
  999. begin
  1000. hp^.nextpara:=hp^.firstpara;
  1001. hp:=hp^.next;
  1002. end;
  1003. pt:=left;
  1004. while assigned(pt) do
  1005. begin
  1006. bestord:=nil;
  1007. if (tcallparanode(pt).left.nodetype=ordconstn) and
  1008. is_integer(pt.resulttype) then
  1009. begin
  1010. hp:=procs;
  1011. while assigned(hp) do
  1012. begin
  1013. def_to:=hp^.nextpara^.paratype.def;
  1014. { to be sure, it couldn't be something else,
  1015. also the defs here are all in the range
  1016. so now find the closest range }
  1017. if not is_integer(def_to) then
  1018. internalerror(43297815);
  1019. if (not assigned(bestord)) or
  1020. ((porddef(def_to)^.low>bestord^.low) or
  1021. (porddef(def_to)^.high<bestord^.high)) then
  1022. bestord:=porddef(def_to);
  1023. hp:=hp^.next;
  1024. end;
  1025. end;
  1026. { if a bestmatch is found then remove the other
  1027. procs which don't match the bestord }
  1028. if assigned(bestord) then
  1029. begin
  1030. hp:=procs;
  1031. procs:=nil;
  1032. while assigned(hp) do
  1033. begin
  1034. hp2:=hp^.next;
  1035. { keep matching bestord, dispose the others }
  1036. if (porddef(hp^.nextpara^.paratype.def)=bestord) then
  1037. begin
  1038. hp^.next:=procs;
  1039. procs:=hp;
  1040. end
  1041. else
  1042. dispose(hp);
  1043. hp:=hp2;
  1044. end;
  1045. end;
  1046. { update nextpara for all procedures }
  1047. hp:=procs;
  1048. while assigned(hp) do
  1049. begin
  1050. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  1051. hp:=hp^.next;
  1052. end;
  1053. pt:=tcallparanode(pt).right;
  1054. end;
  1055. end;
  1056. { Check if there are convertlevel 1 and 2 differences
  1057. left for the parameters, then discard all convertlevel
  1058. 2 procedures. The value of convlevelXfound can still
  1059. be used, because all convertables are still here or
  1060. not }
  1061. if assigned(procs) and assigned(procs^.next) then
  1062. begin
  1063. { reset nextpara for all procs left }
  1064. hp:=procs;
  1065. while assigned(hp) do
  1066. begin
  1067. hp^.nextpara:=hp^.firstpara;
  1068. hp:=hp^.next;
  1069. end;
  1070. pt:=left;
  1071. while assigned(pt) do
  1072. begin
  1073. if (cpf_convlevel1found in tcallparanode(pt).callparaflags) and
  1074. (cpf_convlevel2found in tcallparanode(pt).callparaflags) then
  1075. begin
  1076. hp:=procs;
  1077. procs:=nil;
  1078. while assigned(hp) do
  1079. begin
  1080. hp2:=hp^.next;
  1081. { keep all not act_convertable and all convertlevels=1 }
  1082. if (hp^.nextpara^.argconvtyp<>act_convertable) or
  1083. (hp^.nextpara^.convertlevel=1) then
  1084. begin
  1085. hp^.next:=procs;
  1086. procs:=hp;
  1087. end
  1088. else
  1089. dispose(hp);
  1090. hp:=hp2;
  1091. end;
  1092. end;
  1093. { update nextpara for all procedures }
  1094. hp:=procs;
  1095. while assigned(hp) do
  1096. begin
  1097. hp^.nextpara:=pparaitem(hp^.nextpara^.next);
  1098. hp:=hp^.next;
  1099. end;
  1100. pt:=tcallparanode(pt).right;
  1101. end;
  1102. end;
  1103. if not(assigned(procs)) or assigned(procs^.next) then
  1104. begin
  1105. CGMessage(cg_e_cant_choose_overload_function);
  1106. aktcallprocsym^.write_parameter_lists(nil);
  1107. goto errorexit;
  1108. end;
  1109. {$ifdef TEST_PROCSYMS}
  1110. if (procs=nil) and assigned(nextprocsym) then
  1111. begin
  1112. symtableprocentry:=nextprocsym;
  1113. symtableproc:=symt;
  1114. end;
  1115. end ; { of while assigned(symtableprocentry) do }
  1116. {$endif TEST_PROCSYMS}
  1117. if make_ref then
  1118. begin
  1119. procs^.data^.lastref:=new(pref,init(procs^.data^.lastref,@fileinfo));
  1120. inc(procs^.data^.refcount);
  1121. if procs^.data^.defref=nil then
  1122. procs^.data^.defref:=procs^.data^.lastref;
  1123. end;
  1124. procdefinition:=procs^.data;
  1125. resulttype:=procs^.data^.rettype.def;
  1126. { big error for with statements
  1127. symtableproc:=procdefinition^.owner;
  1128. but neede for overloaded operators !! }
  1129. if symtableproc=nil then
  1130. symtableproc:=procdefinition^.owner;
  1131. location.loc:=LOC_MEM;
  1132. {$ifdef CHAINPROCSYMS}
  1133. { object with method read;
  1134. call to read(x) will be a usual procedure call }
  1135. if assigned(methodpointer) and
  1136. (procdefinition^._class=nil) then
  1137. begin
  1138. { not ok for extended }
  1139. case methodpointer^.nodetype of
  1140. typen,hnewn : fatalerror(no_para_match);
  1141. end;
  1142. methodpointer.free;
  1143. methodpointer:=nil;
  1144. end;
  1145. {$endif CHAINPROCSYMS}
  1146. end; { end of procedure to call determination }
  1147. is_const:=(pocall_internconst in procdefinition^.proccalloptions) and
  1148. ((block_type=bt_const) or
  1149. (assigned(left) and (tcallparanode(left).left.nodetype in [realconstn,ordconstn])));
  1150. { handle predefined procedures }
  1151. if (pocall_internproc in procdefinition^.proccalloptions) or is_const then
  1152. begin
  1153. if assigned(left) then
  1154. begin
  1155. { settextbuf needs two args }
  1156. if assigned(tcallparanode(left).right) then
  1157. pt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,left)
  1158. else
  1159. begin
  1160. pt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,
  1161. tcallparanode(left).left);
  1162. tcallparanode(left).left:=nil;
  1163. left.free;
  1164. left:=nil;
  1165. end;
  1166. end
  1167. else
  1168. begin
  1169. pt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,nil);
  1170. end;
  1171. firstpass(pt);
  1172. pass_1:=pt;
  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. procinfo^.flags:=procinfo^.flags or pi_do_call;
  1204. { add needed default parameters }
  1205. if assigned(procs) and
  1206. (paralength<procdefinition^.maxparacount) then
  1207. begin
  1208. { add default parameters, just read back the skipped
  1209. paras starting from firstpara^.previous, when not available
  1210. (all parameters are default) then start with the last
  1211. parameter and read backward (PFV) }
  1212. if not assigned(procs^.firstpara) then
  1213. pdc:=pparaitem(procs^.data^.para^.last)
  1214. else
  1215. pdc:=pparaitem(procs^.firstpara^.previous);
  1216. while assigned(pdc) do
  1217. begin
  1218. if not assigned(pdc^.defaultvalue) then
  1219. internalerror(751349858);
  1220. left:=gencallparanode(genconstsymtree(pconstsym(pdc^.defaultvalue)),left);
  1221. pdc:=pparaitem(pdc^.previous);
  1222. end;
  1223. end;
  1224. { work trough all parameters to insert the type conversions }
  1225. if assigned(left) then
  1226. tcallparanode(left).firstcallparan(pparaitem(procdefinition^.para^.first),true);
  1227. {$ifndef newcg}
  1228. {$ifdef i386}
  1229. incrementregisterpushed(pprocdef(procdefinition)^.usedregisters);
  1230. {$endif}
  1231. {$ifdef m68k}
  1232. for regi:=R_D0 to R_A6 do
  1233. begin
  1234. if (pprocdef(procdefinition)^.usedregisters and ($800 shr word(regi)))<>0 then
  1235. inc(reg_pushes[regi],t_times*2);
  1236. end;
  1237. {$endif}
  1238. {$endif newcg}
  1239. end;
  1240. { ensure that the result type is set }
  1241. resulttype:=procdefinition^.rettype.def;
  1242. { get a register for the return value }
  1243. if (resulttype<>pdef(voiddef)) then
  1244. begin
  1245. if (procdefinition^.proctypeoption=potype_constructor) then
  1246. begin
  1247. { extra handling of classes }
  1248. { methodpointer should be assigned! }
  1249. if assigned(methodpointer) and assigned(methodpointer.resulttype) and
  1250. (methodpointer.resulttype^.deftype=classrefdef) then
  1251. begin
  1252. location.loc:=LOC_REGISTER;
  1253. registers32:=1;
  1254. { the result type depends on the classref }
  1255. resulttype:=pclassrefdef(methodpointer.resulttype)^.pointertype.def;
  1256. end
  1257. { a object constructor returns the result with the flags }
  1258. else
  1259. location.loc:=LOC_FLAGS;
  1260. end
  1261. else
  1262. begin
  1263. {$ifdef SUPPORT_MMX}
  1264. if (cs_mmx in aktlocalswitches) and
  1265. is_mmx_able_array(resulttype) then
  1266. begin
  1267. location.loc:=LOC_MMXREGISTER;
  1268. registersmmx:=1;
  1269. end
  1270. else
  1271. {$endif SUPPORT_MMX}
  1272. if ret_in_acc(resulttype) then
  1273. begin
  1274. location.loc:=LOC_REGISTER;
  1275. if is_64bitint(resulttype) then
  1276. registers32:=2
  1277. else
  1278. registers32:=1;
  1279. { wide- and ansistrings are returned in EAX }
  1280. { but they are imm. moved to a memory location }
  1281. if is_widestring(resulttype) or
  1282. is_ansistring(resulttype) then
  1283. begin
  1284. location.loc:=LOC_MEM;
  1285. { this is wrong we still need one register PM
  1286. registers32:=0; }
  1287. { we use ansistrings so no fast exit here }
  1288. procinfo^.no_fast_exit:=true;
  1289. registers32:=1;
  1290. end;
  1291. end
  1292. else if (resulttype^.deftype=floatdef) then
  1293. begin
  1294. location.loc:=LOC_FPU;
  1295. registersfpu:=1;
  1296. end
  1297. else
  1298. location.loc:=LOC_MEM;
  1299. end;
  1300. end;
  1301. { a fpu can be used in any procedure !! }
  1302. registersfpu:=procdefinition^.fpu_used;
  1303. { if this is a call to a method calc the registers }
  1304. if (methodpointer<>nil) then
  1305. begin
  1306. case methodpointer.nodetype of
  1307. { but only, if this is not a supporting node }
  1308. typen: ;
  1309. { we need one register for new return value PM }
  1310. hnewn : if registers32=0 then
  1311. registers32:=1;
  1312. else
  1313. begin
  1314. if (procdefinition^.proctypeoption in [potype_constructor,potype_destructor]) and
  1315. assigned(symtableproc) and (symtableproc^.symtabletype=withsymtable) and
  1316. not pwithsymtable(symtableproc)^.direct_with then
  1317. begin
  1318. CGmessage(cg_e_cannot_call_cons_dest_inside_with);
  1319. end; { Is accepted by Delphi !! }
  1320. { this is not a good reason to accept it in FPC if we produce
  1321. wrong code for it !!! (PM) }
  1322. { R.Assign is not a constructor !!! }
  1323. { but for R^.Assign, R must be valid !! }
  1324. if (procdefinition^.proctypeoption=potype_constructor) or
  1325. ((methodpointer.nodetype=loadn) and
  1326. (not(oo_has_virtual in pobjectdef(methodpointer.resulttype)^.objectoptions))) then
  1327. method_must_be_valid:=false
  1328. else
  1329. method_must_be_valid:=true;
  1330. firstpass(methodpointer);
  1331. set_varstate(methodpointer,method_must_be_valid);
  1332. { The object is already used ven if it is called once }
  1333. if (methodpointer.nodetype=loadn) and
  1334. (tloadnode(methodpointer).symtableentry^.typ=varsym) then
  1335. pvarsym(tloadnode(methodpointer).symtableentry)^.varstate:=vs_used;
  1336. registersfpu:=max(methodpointer.registersfpu,registersfpu);
  1337. registers32:=max(methodpointer.registers32,registers32);
  1338. {$ifdef SUPPORT_MMX}
  1339. registersmmx:=max(methodpointer.registersmmx,registersmmx);
  1340. {$endif SUPPORT_MMX}
  1341. end;
  1342. end;
  1343. end;
  1344. if inlined then
  1345. right:=inlinecode;
  1346. { determine the registers of the procedure variable }
  1347. { is this OK for inlined procs also ?? (PM) }
  1348. if assigned(right) then
  1349. begin
  1350. registersfpu:=max(right.registersfpu,registersfpu);
  1351. registers32:=max(right.registers32,registers32);
  1352. {$ifdef SUPPORT_MMX}
  1353. registersmmx:=max(right.registersmmx,registersmmx);
  1354. {$endif SUPPORT_MMX}
  1355. end;
  1356. { determine the registers of the procedure }
  1357. if assigned(left) then
  1358. begin
  1359. registersfpu:=max(left.registersfpu,registersfpu);
  1360. registers32:=max(left.registers32,registers32);
  1361. {$ifdef SUPPORT_MMX}
  1362. registersmmx:=max(left.registersmmx,registersmmx);
  1363. {$endif SUPPORT_MMX}
  1364. end;
  1365. errorexit:
  1366. { Reset some settings back }
  1367. if assigned(procs) then
  1368. dispose(procs);
  1369. if inlined then
  1370. include(procdefinition^.proccalloptions,pocall_inline);
  1371. aktcallprocsym:=oldcallprocsym;
  1372. end;
  1373. {****************************************************************************
  1374. TPROCINLINENODE
  1375. ****************************************************************************}
  1376. constructor tprocinlinenode.create(callp,code : tnode);
  1377. begin
  1378. inherited create(procinlinen);
  1379. inlineprocsym:=tcallnode(callp).symtableprocentry;
  1380. retoffset:=-4; { less dangerous as zero (PM) }
  1381. para_offset:=0;
  1382. {$IFDEF NEWST}
  1383. {Fixme!!}
  1384. internalerror($00022801);
  1385. {$ELSE}
  1386. para_size:=inlineprocsym^.definition^.para_size(target_os.stackalignment);
  1387. if ret_in_param(inlineprocsym^.definition^.rettype.def) then
  1388. para_size:=para_size+target_os.size_of_pointer;
  1389. {$ENDIF NEWST}
  1390. { copy args }
  1391. inlinetree:=code;
  1392. registers32:=code.registers32;
  1393. registersfpu:=code.registersfpu;
  1394. {$ifdef SUPPORT_MMX}
  1395. registersmmx:=code.registersmmx;
  1396. {$endif SUPPORT_MMX}
  1397. {$IFDEF NEWST}
  1398. {Fixme!!}
  1399. {$ELSE}
  1400. resulttype:=inlineprocsym^.definition^.rettype.def;
  1401. {$ENDIF NEWST}
  1402. end;
  1403. destructor tprocinlinenode.destroy;
  1404. begin
  1405. inlinetree.free;
  1406. inherited destroy;
  1407. end;
  1408. function tprocinlinenode.getcopy : tnode;
  1409. var
  1410. n : tprocinlinenode;
  1411. begin
  1412. n:=tprocinlinenode(inherited getcopy);
  1413. if assigned(inlinetree) then
  1414. n.inlinetree:=inlinetree.getcopy
  1415. else
  1416. n.inlinetree:=nil;
  1417. n.inlineprocsym:=inlineprocsym;
  1418. n.retoffset:=retoffset;
  1419. n.para_offset:=para_offset;
  1420. n.para_size:=para_size;
  1421. getcopy:=n;
  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.10 2000-10-14 21:52:55 peter
  1439. * fixed memory leaks
  1440. Revision 1.9 2000/10/14 10:14:50 peter
  1441. * moehrendorf oct 2000 rewrite
  1442. Revision 1.8 2000/10/01 19:48:24 peter
  1443. * lot of compile updates for cg11
  1444. Revision 1.7 2000/09/28 19:49:52 florian
  1445. *** empty log message ***
  1446. Revision 1.6 2000/09/27 18:14:31 florian
  1447. * fixed a lot of syntax errors in the n*.pas stuff
  1448. Revision 1.5 2000/09/24 21:15:34 florian
  1449. * some errors fix to get more stuff compilable
  1450. Revision 1.4 2000/09/24 20:17:44 florian
  1451. * more conversion work done
  1452. Revision 1.3 2000/09/24 15:06:19 peter
  1453. * use defines.inc
  1454. Revision 1.2 2000/09/20 21:52:38 florian
  1455. * removed a lot of errors
  1456. Revision 1.1 2000/09/20 20:52:16 florian
  1457. * initial revision
  1458. }